| |
以下の条件と、Dictionaryオブジェクトが使える環境（大抵は使えると思います）なら
こんなコードかな？
上手く行かなかったゴメン
B1セルに日付と認められる値が有るシートを転記先のシートとする
転記先のシートは、同一レイアウトで、店舗名も全て同位置に有る物とする
以下を標準モジュールに記述して下さい
Option Explicit
'シートの最終行位置を定数として宣言
Const clngSheetEnd As Long = 65536
Public Sub Classification()
'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(ByVal _
vntValue As Variant) As Boolean
' 日付のチェック
If vntValue = "" Then
Exit Function
End If
If Len(vntValue) <> 8 Then
Exit Function
End If
vntValue = Left(vntValue, 4) _
& "/" & Mid(vntValue, 5, 2) _
& "/" & Right(vntValue, 2)
If IsDate(vntValue) Then
DateCheck = True
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, "B").Value
'もし、日付と認められるなら
If DateCheck(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
|
|
Hirofumi
- 04/5/9(日) 11:39 -
