|
こんな様に成るのかな?
Option Explicit
Public Sub AddUp2()
Dim i As Long
Dim j As Long
Dim lngFindCol As Long
Dim lngFindRow As Long
Dim vntData As Variant
Dim vntResult As Variant
Dim dicColIndex As Object
Dim dicRowIndex As Object
Dim vntKey As Variant
Dim vntCustomer As Variant
Dim rngResult As Range
Dim rngList As Range
Dim lngRows As Long
Dim lngColumns As Long
Dim strProm As String
'得意先の一覧表を作成(Sheet2A列に書かれるグループ順に羅列)
vntCustomer = Array("得意先A", "得意先B", "得意先C")
'Dictionaryオブジェクトのインスタンスを取得(Sheet2A列のIndex用)
Set dicRowIndex = CreateObject("Scripting.Dictionary")
'Dictionaryオブジェクトのインスタンスを取得(Sheet1行の店Index用)
Set dicColIndex = CreateObject("Scripting.Dictionary")
'シートの表の先頭セルを設定
Set rngResult = Worksheets("Sheet2").Cells(1, "A")
'店名のセル位置を取得
With rngResult
lngColumns = .Offset(, 256 - .Column).End(xlToLeft).Column - .Column
If lngColumns <= 0 Then
strProm = "店名データが有りません"
GoTo Wayout
End If
vntData = .Offset(, 1).Resize(, lngColumns).Value
End With
With dicColIndex
For i = 1 To UBound(vntData, 2)
If Not .Exists(vntData(1, i)) Then
.Add vntData(1, i), i
Else
strProm = "店名が重複しています"
GoTo Wayout
End If
Next i
End With
'項目区2のセル位置を取得
With rngResult
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "項目2データが有りません"
GoTo Wayout
End If
vntData = .Offset(1).Resize(lngRows).Value
End With
With dicRowIndex
For i = 1 To UBound(vntData, 1)
If vntData(i, 1) <> "" Then
If j <= UBound(vntCustomer) Then
vntKey = vntCustomer(j) & vbTab & vntData(i, 1)
If Not .Exists(vntKey) Then
.Add vntKey, i
Else
strProm = "?が重複しています"
GoTo Wayout
End If
End If
Else
j = j + 1
End If
Next i
End With
'結果出力用配列を確保
ReDim vntResult(1 To lngRows, 1 To lngColumns)
'Sheet1の商品コードのセル位置を基準として設定
Set rngList = Worksheets("Sheet1").Cells(1, "A")
'"Sheet1"のデータ数を取得
With rngList
'データの行数を取得
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
'もし、データが有る場合
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
End With
'表に転記
For i = 1 To lngRows
vntData = rngList.Offset(i).Resize(, 8).Value
If vntData(1, 8) = "売上" Then
'得意先&項目2の行位置を探索
vntKey = vntData(1, 2) & vbTab & vntData(1, 3)
With dicRowIndex
If .Exists(vntKey) Then
lngFindRow = .Item(vntKey)
Else
lngFindRow = 0
End If
End With
'店名を探索
With dicColIndex
If .Exists(vntData(1, 7)) Then
lngFindCol = .Item(vntData(1, 7))
Else
lngFindCol = 0
End If
End With
If lngFindCol > 0 And lngFindRow > 0 Then
'発見した行列に値を加算
vntResult(lngFindRow, lngFindCol) _
= vntResult(lngFindRow, lngFindCol) + vntData(1, 6)
End If
End If
Next i
Application.ScreenUpdating = False
'結果を出力
With rngResult.Offset(1, 1)
.Resize(UBound(vntResult, 1), _
UBound(vntResult, 2)).Value = vntResult
End With
Application.ScreenUpdating = True
strProm = "処理が完了しました"
Wayout:
'Dictionaryオブジェクトのインスタンスを破棄
Set dicRowIndex = Nothing
Set dicColIndex = Nothing
Set rngList = Nothing
Set rngResult = Nothing
Beep
MsgBox strProm
End Sub
尚、前回のコードで以下が違っていたので修正
'得意先と商品コード列を削除
' rngListTop.Offset(, -2).EntireColumn.Delete '★変更
rngListTop.Offset(, -2).Resize(, 2).EntireColumn.Delete
|
|