| |
解りました、転記先のE1は、シリアル値で文字列では有りません
Sheet1のB列の日付は、完全に文字列なんですね？
例「20040401」と入っているんですね！
だとすると、大分コードを書き換える様なので全文を載せますので
此れで試して下さい
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
|
|
Hirofumi
- 04/5/10(月) 21:48 -
