| |
▼Hirofumi さん、こんばんは。度々、申し訳ありません（ＴＴ）
ご指示のとおり試しました。エラーは出ませんでした。しかし、以下の「←」の部分について、「同一の店名があります」というメッセージが出てしまい、転記がなされません。どのようにしたら良いのでしょうか？
>Option Explicit
>
>'シートの最終行位置を定数として宣言
>Const clngSheetEnd As Long = 65536
>
>Public Sub Classification2()
>
> 'Sheet1のデータ先頭行を定数として宣言
> Const clngDataTop As Long = 3
>
> Dim i As Long
> Dim lngDataEnd As Long
> Dim dicSheets As Object
> Dim dicStore As Object
> Dim vntData As Variant
> Dim lngSheetNo As Long
> Dim lngStoreNo As Long
> Dim blnCopy As Boolean
>
> '画面更新を停止
> Application.ScreenUpdating = False
>
> 'シートのIndexをDictionaryとして取得
> Set dicSheets _
> = CreateObject("Scripting.Dictionary")
> '店のIndexをDictionaryとして取得
> Set dicStore _
> = CreateObject("Scripting.Dictionary")
>
> 'シートのIndexを作成
> If Not MakeSheetsIndex(dicSheets, lngSheetNo) Then
> GoTo ExitHandler
> End If
>
> '店のIndexを作成
> If Not MakeStoreIndex(dicStore, lngSheetNo) Then
> GoTo ExitHandler
> End If
>
> 'データの有るシートに就いて
> With Worksheets("Sheet1")
> 'データの最終行を取得
> lngDataEnd = .Cells(clngSheetEnd, "A").End(xlUp).Row
> 'データの有る先頭行〜最終行まで繰り返し
> For i = clngDataTop To lngDataEnd
> '配列にi行のA、B列を取得
> vntData = .Cells(i, 1).Resize(, 2).Value
> 'もし、i行B列のセル値が日付と認識されるなら
> If DateCheck(vntData(1, 2)) Then
> 'もし、シートのIndexにこの日付が有るなら
> If dicSheets.Exists(vntData(1, 2)) Then
> 'シートの番号を取得
> lngSheetNo _
> = CLng(dicSheets.Item(vntData(1, 2)))
> 'コピーフラグをTrueに
> blnCopy = True
> '日付が無いなら
> Else
> '当月分と認めず、このグループを無視
> MsgBox vntData(1, 2) & "、他の月の分です。"
> 'コピーフラグをFalseに
> blnCopy = False
> End If
> 'i行B列のセル値が日付と認識されないなら
> Else
> 'コピーフラグがTrueなら
> If blnCopy Then
> '店舗Indexにi行A列の値が有るなら
> If dicStore.Exists(vntData(1, 1)) Then
> '店舗の行位置を取得
> lngStoreNo _
> = CLng(dicStore.Item(vntData(1, 1)))
> 'Sheet1のi行D、E列をコピーして、店舗の行位置に張りつけ
> .Cells(i, "D").Resize(, 2).Copy _
> Worksheets(lngSheetNo).Cells(lngStoreNo, "Q")
> End If
> End If
> End If
> Next i
> End With
>
> Beep
> MsgBox "処理が完了しました"
>
>ExitHandler:
>
> '画面更新を再開
> Application.ScreenUpdating = True
>
> 'Dictionaryを破棄
> Set dicSheets = Nothing
> Set dicStore = Nothing
>
>End Sub
>
>Private Function DateCheck(vntValue As Variant) As Boolean
>
>' 日付のチェック
>
> Dim vntResult As Variant
>
> If vntValue = "" Then
> Exit Function
> End If
> vntValue = Trim(vntValue)
> If Len(vntValue) <> 8 Then
> Exit Function
> End If
> vntResult = Left(vntValue, 4) _
> & "/" & Mid(vntValue, 5, 2) _
> & "/" & Right(vntValue, 2)
> If IsDate(vntResult) Then
> DateCheck = True
> vntValue = DateValue(vntResult)
> End If
>
>End Function
>
>Private Function MakeSheetsIndex(dicSheets As Object, _
> lngSheetNo As Long) As Boolean
>
>' B1セルに日付の有るシートのIndexを作成
>
>
> Dim i As Long
> Dim vntDate As Variant
>
> 'ワークシートコレクションに就いて
> With Worksheets
> 'コレクションの先頭から終りまで繰り返し
> For i = 1 To .Count
> 'シートiのB1の値を取得
> vntDate = .Item(i).Cells(1, "E").Value
> 'もし、日付と認められるなら
> If IsDate(vntDate) Then
> 'シートのIndexにこの日付が有る場合
> If dicSheets.Exists(vntDate) Then
> Beep
> MsgBox "同一の日付が有ります"
> Exit Function
> '日付が無い場合
> Else
> 'Indexにこの日付とシート番号を追加
> dicSheets.Add vntDate, i
> '最初にIndexに追加されたシート番号を保存
> If lngSheetNo = 0 Then
> lngSheetNo = i
> End If
> End If
> End If
> Next i
> End With
>
> MakeSheetsIndex = True
>
>End Function
>
>Private Function MakeStoreIndex(dicStore As Object, _
> lngSheetNo As Long) As Boolean
>
>' 店舗のIndexを作成
>
> '店舗データの先頭行位置を定数宣言
> Const clngDataTop As Long = 5
>
> Dim i As Long
> Dim vntData As Variant
>
> '最初にIndexに追加されたシート番号に就いて
> With Worksheets(lngSheetNo)
> '店舗名を配列に取得
> vntData = Range(.Cells(clngDataTop, "A"), _
> .Cells(clngSheetEnd, "A").End(xlUp)).Value
> End With
> '店舗Indexに就いて
> With dicStore
> '店舗名の先頭から終まで繰り返し
> For i = 1 To UBound(vntData, 1)
> 'Indexにi番目の店舗名が有るなら
> If .Exists(vntData(i, 1)) Then
> Beep
> MsgBox "同一の店名が有ります" ←ここです
> Exit Function
> 'i番目の店舗名が無いなら
> Else
> 'Indexに店舗名と行位置を追加
> .Add vntData(i, 1), i + clngDataTop - 1
> End If
> Next i
> End With
>
> MakeStoreIndex = True
>
>End Function
|
|
ハルコ
- 04/5/10(月) 23:12 -
