| |
オートフィルタを使わずに、単純な手法で行っています
1、Listを「店舗」昇順、「日付」昇順で整列します
ただ、今回のコードでは、Listを元に戻す為、最終列の後ろに再整列用のKeyを
先に出力しています
2、Listの「店舗」を上から見ていきます、探索KeyのKeyB1と同じ値が有った場合
KeyA1の値になるまで集計を行います
3、次にListの「日付」を見て行き、KeyA1と同じ値が初めて有った時
この行位置を記録し、同じ値の行をカウントしていきます
4、Listの「店舗」が違ったら、集計とカウントを辞めます
5、lngTopで記録した行位置から、カウントした行数を、List2にCopyし、
集計結果を出力して終わります
Option Explicit
Public Sub Sample()
'◆Listのデータ列数（A列〜AG列）
Const clngColumns As Long = 33
'◆「1係」の列位置を指定(基準セル位置からの列Offset：基準がA1で「1係」がD列なら3)
Const clngBegin As Long = 3
'◆「日付」の列位置を指定(基準セル位置からの列Offset：基準がA1で「日付」がA列なら0)
Const clngDate As Long = 0
'◆「店舗」の列位置を指定(基準セル位置からの列Offset：基準がA1で「店舗」がB列なら1)
Const clngKey As Long = 1
'◆「項目」の列位置を指定(基準セル位置からの列Offset：基準がA1で「項目」がC列なら2)
Const clngItem As Long = 2
Dim i As Long
Dim j As Long
Dim lngRows As Long
Dim rngList As Range
Dim vntDate As Variant
Dim vntKeys As Variant
Dim vntItems As Variant
Dim rngResult As Range
Dim vntResult As Variant
Dim vntData As Variant
Dim vntKeyA1 As Variant
Dim vntKeyB1 As Variant
Dim lngTop As Long
Dim lngCount As Long
Dim lngIndex As Long
Dim strProm As String
'◆Listの先頭セル位置を基準とする（列見出し「日付」のセル位置）
Set rngList = Worksheets("List").Cells(1, "A")
'◆List2の先頭セル位置を基準とする（列見出し「日付」のセル位置）
Set rngResult = Worksheets("List2").Cells(5, "A")
With rngResult
'行数の取得
lngRows = .Offset(Rows.Count - .Row, clngItem).End(xlUp).Row - .Row
If lngRows > 0 Then
'先回の結果をクリア (結果表示先List2のA:AF)
.Offset(1).Resize(lngRows, clngColumns - 1).ClearContents
End If
'「日付」の抽出条件を取得
vntKeyA1 = .Parent.Cells(2, 2).Value
'「店舗」の抽出条件を取得
vntKeyB1 = .Parent.Cells(3, 2).Value
End With
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
'復帰用整列Keyを作成
ReDim vntData(1 To lngRows, 1 To 1)
For i = 1 To lngRows
vntData(i, 1) = i
Next i
'復帰用Keyの出力
.Offset(1, clngColumns) _
.Resize(lngRows).Value = vntData
'データを「店舗」昇順の「日付」昇順で整列
.Offset(1).Resize(lngRows, clngColumns + 1).Sort _
Key1:=.Offset(1, clngKey), Order1:=xlAscending, _
Key2:=.Offset(1, clngDate), Order2:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'「日付」列データを配列に取得
vntDate = .Offset(1, clngDate).Resize(lngRows + 1).Value
'「店舗」列データを配列に取得
vntKeys = .Offset(1, clngKey).Resize(lngRows + 1).Value
'「項目」列データを配列に取得
vntItems = .Offset(1, clngItem).Resize(lngRows + 1).Value
End With
'結果出力用配列を確保(売上と差益の累計値の集計用)
ReDim vntResult(1, clngColumns - clngBegin)
vntResult(0, 0) = "売上累計"
vntResult(1, 0) = "差益累計"
'Listのデータ行全てに就いて繰り返し
For i = 1 To lngRows
'「店舗」の値がKeyB1の値と合致した場合
If StrComp(vntKeys(i, 1), vntKeyB1, vbTextCompare) = 0 Then
'「日付」がKeyA1の値以下の場合
If vntDate(i, 1) <= vntKeyA1 Then
'項目が「売上」か"差益"なら
If vntItems(i, 1) = "売上" Or vntItems(i, 1) = "差益" Then
'1行分データを配列に取得
vntData = rngList.Offset(i, clngBegin) _
.Resize(, clngColumns - clngBegin).Value
'項目が「売上」なら
If vntItems(i, 1) = "売上" Then
lngIndex = 0
Else
lngIndex = 1
End If
'「係」 単位に集計
For j = 1 To clngColumns - clngBegin
vntResult(lngIndex, j) _
= vntResult(lngIndex, j) + vntData(1, j)
Next j
End If
'「日付」がKeyA1の値合致し、lngTopが0の場合
If vntDate(i, 1) = vntKeyA1 And lngTop = 0 Then
'抽出行の先頭行位置を記録
lngTop = i
'抽出行数を1に
lngCount = 1
Else
'抽出行数を更新
lngCount = lngCount + 1
End If
End If
Else
'探索するKeyB1を通り過ぎた場合
If lngTop > 0 Then
'Forを抜ける
Exit For
End If
End If
Next i
'画面更新を停止
Application.ScreenUpdating = False
'結果を出力
With rngResult
'抽出結果が有るなら
If lngTop > 0 Then
'列見出しを貼り付け
rngList.Offset(, 1).Resize(lngCount, _
clngColumns - 1).Copy Destination:=.Item(1)
'抽出結果を貼り付け
rngList.Offset(lngTop, 1).Resize(lngCount, _
clngColumns - 1).Copy Destination:=.Offset(1)
'累計を出力
.Offset(lngCount + 1, 1).Resize(2, clngColumns _
- clngBegin).Value = vntResult
strProm = "処理が完了しました"
Else
strProm = "抽出結果が有りません"
End If
End With
With rngList
'Listの再整列
.Offset(1).Resize(lngRows, clngColumns + 1).Sort _
Key1:=.Offset(1, clngColumns), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'Key列の削除
.Offset(1, clngColumns).EntireColumn.Delete
End With
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
|
|
Hirofumi
- 07/5/5(土) 3:53 -
