| |
上手く行かなかったらゴメン
Option Explicit
Public Sub AddUp()
Dim i As Long
Dim lngFindCol As Long
Dim lngFindRow As Long
Dim vntData As Variant
Dim lngOver As Long
Dim lngColNum As Long
Dim lngRowNum As Long
Dim rngScopeCol As Range
Dim rngScopeRow As Range
Dim rngListTop As Range
Dim rngColItem As Range
Dim rngRowItem As Range
Dim lngRows As Long
Dim strProm As String
'"Sheet1"のデータを配列に取得
With Worksheets("Sheet1").Cells(1, "A")
'データの行数を取得
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
'もし、データが有る場合
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
vntData = .Offset(1).Resize(lngRows, 8).Value
End With
Application.ScreenUpdating = False
'表を作るシートの表の先頭セル(後から2列削除に成るので、2列左の位置）
Set rngListTop = Worksheets("Sheet2").Cells(1, "C")
'列項目の初期値
Set rngColItem = rngListTop.Offset(, 1)
lngColNum = 0
'行項目の初期値
Set rngRowItem = rngListTop.Offset(1, -1)
lngRowNum = 0
'表に転記
With rngListTop
For i = 1 To UBound(vntData, 1)
If vntData(i, 8) = "売上" Then
'商品コードの行位置を探索
lngFindRow = ItemSearch(vntData(i, 1), _
rngScopeRow, lngOver, 1)
'探索値が無かった場合（未発見）
If lngFindRow = 0 Then
'探索範囲行数を更新
lngRowNum = lngRowNum + 1
'挿入位置に列を挿入
With .Offset(lngOver)
.EntireRow.Insert
End With
'挿入位置を発見位置に設定
lngFindRow = lngOver
'行項目の初期値を再設定
Set rngRowItem = .Offset(1, -1)
'挿入位置に商品コードを記入
.Offset(lngFindRow, -1).Value = vntData(i, 1)
.Offset(lngFindRow, -2).Value = vntData(i, 2)
.Offset(lngFindRow, 0).Value = vntData(i, 3)
'商品コードの探索範囲の取得
Set rngScopeRow = rngRowItem.Resize(lngRowNum)
End If
'店名を探索
lngFindCol = ItemSearch(vntData(i, 7), _
rngScopeCol, lngOver, 1)
'店名が無かった場合（未発見）
If lngFindCol = 0 Then
'探索範囲列数を更新
lngColNum = lngColNum + 1
'挿入位置に列を挿入
With .Offset(, lngOver)
.EntireColumn.Insert
End With
'挿入位置を発見位置に設定
lngFindCol = lngOver
'列項目の初期値を再設定
Set rngColItem = .Offset(, 1)
With .Offset(, lngFindCol)
'コード番号を記入
.Value = vntData(i, 7)
End With
'店名の範囲を設定
Set rngScopeCol = rngColItem.Resize(, lngColNum)
End If
'発見した行列に値を記入
.Offset(lngFindRow, lngFindCol).Value _
= .Offset(lngFindRow, lngFindCol).Value + vntData(i, 6)
End If
Next i
End With
'得意先別に1行空ける
With rngRowItem
vntData = .Offset(, -1).Resize(lngRowNum).Value
For i = UBound(vntData, 1) - 1 To 1 Step -1
If vntData(i + 1, 1) <> vntData(i, 1) Then
.Offset(i).EntireRow.Insert
End If
Next i
End With
'得意先と商品コード列を削除
rngListTop.Offset(, -2).EntireColumn.Delete
strProm = "処理が完了しました"
Wayout:
Set rngScopeCol = Nothing
Set rngScopeRow = Nothing
Set rngListTop = Nothing
Set rngColItem = Nothing
Set rngRowItem = Nothing
Application.ScreenUpdating = True
Beep
MsgBox strProm
End Sub
Private Function ItemSearch(vntKey As Variant, _
rngScope As Range, _
Optional lngOver As Long, _
Optional lngCollation As Long = 1) As Long
Dim vntFind As Variant
Dim lngDataTop As Long
If rngScope Is Nothing Then
lngOver = 1
Exit Function
End If
'Matchによる二分探索
vntFind = Application.Match(vntKey, rngScope, lngCollation)
'もし、エラーで無いなら
If Not IsError(vntFind) Then
'もし、Key値と探索位置の値が等しいなら
If vntKey = rngScope.Cells(vntFind).Value Then
'戻り値として、位置を代入
ItemSearch = vntFind
End If
'Key値を超える最小値のある行
lngOver = vntFind + 1
Else
lngOver = 1
End If
End Function
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
