| |
「 a店」に対する、対策ならそれでOkです
その他の物に対応する様にした場合は、以下の様に成ります
２つのプロシージャが大きく変わり、１つのプロシージャが追加に成ります
尚、転記先のセルの書式設定はコメントアウトして有りますので必要なら活かして下さい
ただし、セルの書式設定を活かすと遅く成る可能性が有ります
また、「支店」にも対応した積もりです
'★このプロシージャ変更
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
Dim j As Long '★追加
Dim vntResult As Variant '★追加
Dim wksData As Worksheet '★追加
Dim wksResult As Worksheet '★追加
'画面更新を停止
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
'「集計表」シートの参照を格納
Set wksData = Worksheets("Sheet1")
'データの有るシートに就いて
With wksData
'データの最終行を取得
lngDataEnd = .Cells(clngSheetEnd, "A").End(xlUp).Row
End With
'データの有る先頭行〜最終行まで繰り返し
For i = clngDataTop To lngDataEnd
'配列にi行のA、B、C、D、E列を取得
vntData = wksData.Cells(i, "A").Resize(, 5).Value '★修正
'もし、i行B列のセル値が日付と認識されるなら
If DateCheck(vntData(1, 2)) Then
With dicSheets
'もし、シートのIndexにこの日付が有るなら
If .Exists(vntData(1, 2)) Then
'シートの番号を取得
lngSheetNo = CLng(.Item(vntData(1, 2)))
'転記先の参照を格納
Set wksResult = Worksheets(lngSheetNo)
'コピーフラグをTrueに
blnCopy = True
'日付が無いなら
Else
'当月分と認めず、このグループを無視
MsgBox vntData(1, 2) & "、他の月の分です。"
'コピーフラグをFalseに
blnCopy = False
End If
End With
'i行B列のセル値が日付と認識されないなら
Else
'コピーフラグがTrueなら
If blnCopy Then
'店舗名から「店」、「支店」、Spaceを削除
vntData(1, 1) = NameControl(vntData(1, 1)) '★追加
'店舗Indexにi行A列の値が有るなら
If dicStore.Exists(vntData(1, 1)) Then
'店舗の行位置を取得
lngStoreNo _
= CLng(dicStore.Item(vntData(1, 1)))
With wksResult.Cells(lngStoreNo, "Q").Resize(, 2)
'転記先の店舗の行位置Q、R列の値を取得
vntResult = .Value '★追加
'転記先Q、R列の値にデータを加算
For j = 1 To 2 '★追加
vntResult(1, j) _
= vntResult(1, j) _
+ vntData(1, 3 + j) '★追加
Next j '★追加
'転記先Q、R列の位置に代入
.Value = vntResult '★追加
'セルの書式設定
' .NumberFormatLocal = "#,##0_ " '★追加
End With
End If
End If
End If
Next i
Beep
MsgBox "処理が完了しました"
ExitHandler:
'画面更新を再開
Application.ScreenUpdating = True
'Dictionaryを破棄
Set dicSheets = Nothing
Set dicStore = Nothing
Set wksData = Nothing '★追加
Set wksResult = Nothing '★追加
End Sub
'★このプロシージャ変更
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)
'配列に「合計」が出てきたらForを抜ける
If Trim(vntData(i, 1)) = "合計" Then
Exit For
End If
'店舗名から「店」、「支店」、Spaceを削除
vntData(i, 1) = NameControl(vntData(i, 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
'★このプロシージャ新規追加
Private Function NameControl(ByVal vntValue As Variant) As Variant
Const cstrExtension1 As String = "支店"
Const cstrExtension2 As String = "店"
'Spaceを削除
vntValue = Trim(vntValue)
'右2文字が「支店」の場合
If Right(vntValue, 2) = cstrExtension1 Then
'「支店」を削除
NameControl = Left(vntValue, Len(vntValue) - 2)
Else
'右1文字が「店」の場合
If Right(vntValue, 1) = cstrExtension2 Then
'「店」を削除
NameControl = Left(vntValue, Len(vntValue) - 1)
Else
NameControl = vntValue
End If
End If
End Function
|
|
Hirofumi
- 04/5/16(日) 1:45 -
