| |
▼Hirofumi さん、こんばんは。ご指摘のとおりコードを入力しましたが、だめみたいです。私もコードの内容について勉強しているのですが、わかりません。
それで、参考までに今現在のコードを添付致します。それでも判明できなかったら、非常に残念ですが、ここであきらめるしかないです。これ以上、ご迷惑をおかけすることはできないので、後は、私で、Hirohumiさんのコードを元に勉強して、
解明してみます。
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("集計表")
'データの最終行を取得
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 j As Long '★この行追加
Dim vntDate As Variant
Dim vntExclude As Variant '★この行追加
Dim blnExclude As Boolean '★この行追加
'除外するシート名を配列に（""で括り「,」で区切って羅列）
vntExclude = Array("シート１", "シート２", "シート３", "シート４", "シート５", "シート３７", "シート３８") '★この行追加
'ワークシートコレクションに就いて
With Worksheets
'コレクションの先頭から終りまで繰り返し
For i = 1 To .Count
'除外フラグをFalseに
blnExclude = False '★この行追加
'除外するシート名の先頭〜最終まで繰り返し
For j = 0 To UBound(vntExclude) '★この行追加
'もしi番目のシート名が除外するシート名と一致するなら
If .Item(i).Name = vntExclude(j) Then '★この行追加
''除外フラグをTrueの
blnExclude = True '★この行追加
'Forを抜ける
Exit For '★この行追加
End If '★この行追加
Next j '★この行追加
'除外するシートで無い場合
If Not blnExclude Then '★この行追加
'シートiのE1の値を取得
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 '★この行追加
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, "B"), _
.Cells(clngSheetEnd, "B").End(xlUp)).Value '★この行修正
End With
'店舗Indexに就いて
With dicStore
'店舗名の先頭から終まで繰り返し
For i = 1 To UBound(vntData, 1)
'店舗名に「店」が無い場合、「店」を追加する
If Right(vntData(i, 1), 1) <> "店" Then '★この行追加
vntData(i, 1) = vntData(i, 1) & "店" '★この行追加
End If '★この行追加
'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/12(水) 22:17 -
