| |
AdvancedFilterを使って店別・月別・項目別・係別で「売上」だけを集計しています
尚、日付は、1年分しか無い物としてコードを作っています
また、日付が、シリアル値の場合と「20070401」形式の場合でコードが違います
日付が、シリアル値の場合は、●印の下の行を活かして下さい
日付が、「20070401」形式の場合は、★印の下の行を活かして下さい
(Upのコードはコメントアウトして有ります)
集計結果は、店舗名のシートが有ればそれが使われますし、無い場合は作成されます
ただし、作成されると言っても、見出しが出力される程度でので、
予め、店舗名のシートを作って、罫線、書式等が有るならそれを設定して下さい
Option Explicit
Public Sub Sample()
'List1の各緒言
'◆List1のデータ列数（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 clngStores As Long = 1
'◆「項目」の列位置を指定(基準セル位置からの列Offset：基準がA1で「項目」がC列なら2)
Const clngItem As Long = 2
'出力シートの各緒言
'◆出力基準位置を指定
Const cstrResult As String = "A3"
'◆先頭「01係」の行位置（上記の基準からの行Offset）
Const clngNo As Long = 3
Dim i As Long
Dim j As Long
Dim k As Long
Dim lngTop As Long
Dim lngRow As Long
Dim lngColumn As Long
Dim lngRows As Long
Dim rngList As Range
Dim rngResult() As Range
Dim rngWork As Range
Dim vntResult As Variant
Dim vntStores As Variant
Dim vntData As Variant
Dim vntTitle As Variant
Dim vntItems As Variant
Dim lngMonth As Long
Dim lngPitch As Long
Dim lngCalc As Long
Dim strProm As String
'再計算の方法を保存
lngCalc = Application.Calculation
'◆Listの先頭セル位置を基準とする（列見出し「日付」のセル位置）
Set rngList = Worksheets("List1").Cells(1, "A")
'◆出力表の行見出しを設定
vntTitle = Array("年実績", "前年比", "達成率", "年実績", "年目標")
lngPitch = UBound(vntTitle) + 1
With rngList
'行数の取得
lngRows = .CurrentRegion.Rows.Count - 1
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
vntData = .Offset(1, clngStores).Resize(lngRows + 1).Value
ReDim vntStores(0)
vntStores(0) = vntData(1, 1)
For i = 2 To lngRows
For j = 0 To UBound(vntStores)
If vntData(i, 1) = vntStores(j) Then
Exit For
End If
Next j
If j > UBound(vntStores) Then
ReDim Preserve vntStores(UBound(vntStores) + 1)
vntStores(UBound(vntStores)) = vntData(i, 1)
End If
Next i
Erase vntData
vntItems = .Offset(, clngBegin).Resize(, clngColumns - clngBegin)
End With
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
'出力シートの存在確認
ReDim rngResult(UBound(vntStores))
For i = 0 To UBound(vntStores)
If SheetExists(vntStores(i)) Then
Set rngResult(i) = Worksheets(vntStores(i)).Range(cstrResult)
With rngResult(i).Parent
.Cells.ClearContents
.Activate
End With
Else
Set rngResult(i) = Worksheets.Add( _
After:=ActiveSheet).Range(cstrResult)
rngResult(i).Parent.Name = vntStores(i)
End If
Next i
'作業用シートを追加
With Worksheets
Set rngWork = .Add(After:=.Item(.Count)).Cells(1, "A")
End With
With rngWork
rngList.Resize(, clngColumns).Copy Destination:=.Item(1)
With .Offset(, clngColumns)
.Offset(, 1).Value = rngList.Offset(, clngStores).Value
.Offset(, 2).Value = rngList.Offset(, clngItem).Value
.Offset(1, 2).Value = "売上"
End With
'「店舗」別にAdvancedFilterで、「売上」を抽出
For i = 0 To UBound(vntStores)
'店舗条件を出力
.Offset(1, clngColumns + 1).Value = vntStores(i)
DoFilter rngList.CurrentRegion, .Offset(, clngColumns _
+ 1).Resize(2, 2), .Resize(, clngColumns)
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
If lngRows < 1 Then
Exit For
End If
.Offset(1).Resize(lngRows, clngColumns).Sort _
Key1:=.Offset(1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
vntData = .Offset(1).Resize(lngRows, clngColumns).Value
ReDim vntResult(1 To (clngColumns - clngBegin) * lngPitch, 1 To 12)
lngTop = 1
'★月の値を取得(「20070401」形式の場合)
' lngMonth = Val(Mid(vntData(lngTop, clngDate + 1), 5, 2))
'●月の値を取得(シリアル値の場合)
lngMonth = Month(vntData(lngTop, clngDate + 1))
lngColumn = (lngMonth + 8) Mod 12 + 1
For j = 1 To clngColumns - clngBegin
lngRow = (j - 1) * lngPitch + 1
vntResult(lngRow, lngColumn) = vntData(lngTop, clngBegin + j)
Next j
For j = 2 To lngRows
'★月が違った場合(「20070401」形式の場合)
' If Val(Mid(vntData(j, clngDate + 1), 5, 2)) <> lngMonth Then
'●月が違った場合(シリアル値の場合)
If Month(vntData(j, clngDate + 1)) <> lngMonth Then
lngTop = j
'★月の値を取得(「20070401」形式の場合)
' lngMonth = Val(Mid(vntData(lngTop, clngDate + 1), 5, 2))
'●月の値を取得(シリアル値の場合)
lngMonth = Month(vntData(lngTop, clngDate + 1))
End If
lngColumn = (lngMonth + 8) Mod 12 + 1
For k = 1 To clngColumns - clngBegin
lngRow = (k - 1) * lngPitch + 1
vntResult(lngRow, lngColumn) _
= vntResult(lngRow, lngColumn) _
+ vntData(lngTop, clngBegin + k)
Next k
Next j
With rngResult(i)
.Offset(clngNo, 2).Resize(UBound(vntResult, 1), _
UBound(vntResult, 2)).Value = vntResult
OutputTerminate .Item(1), vntItems, _
Val(Left(vntData(1, clngDate + 1), 4)), vntTitle, clngNo
End With
Next i
rngResult(0).Parent.Activate
End With
strProm = "処理が完了しました"
Wayout:
If Not rngWork Is Nothing Then
Application.DisplayAlerts = False
rngWork.Parent.Delete
Application.DisplayAlerts = True
End If
With Application
.Calculation = lngCalc
.Calculate
.ScreenUpdating = True
End With
Set rngWork = Nothing
Set rngList = Nothing
For i = 0 To UBound(rngResult)
Set rngResult(i) = Nothing
Next i
MsgBox strProm, vbInformation
End Sub
Private Sub DoFilter(rngScope As Range, rngCriteria As Range, _
rngCopyTo As Range)
rngScope.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=rngCriteria, _
CopyToRange:=rngCopyTo, _
Unique:=False
End Sub
Private Function SheetExists(vntName As Variant) As Boolean
Dim i As Long
For i = 1 To Worksheets.Count
If StrComp(Worksheets(i).Name, vntName, vbTextCompare) = 0 Then
Exit For
End If
Next i
If i <= Worksheets.Count Then
vntName = Worksheets(i).Name
SheetExists = True
End If
End Function
Private Sub OutputTerminate(rngTop As Range, _
vntName As Variant, _
lngYear As Long, _
vntTitle As Variant, _
lngStart As Long)
Dim i As Long
Dim j As Long
Dim lngPitch As Long
Dim vntResult As Variant
Dim vntTmp As Variant
'出力ピッチを取得
lngPitch = UBound(vntTitle) + 1
'行見出し作成用の配列を作成
ReDim vntResult(1 To UBound(vntName, 2) * lngPitch + lngStart, 1 To 2)
vntResult(1, 1) = "係"
vntResult(2, 2) = Right(CStr(lngYear - 1), 2) & vntTitle(0)
vntResult(3, 2) = Right(CStr(lngYear), 2) & vntTitle(UBound(vntTitle))
For i = 1 To UBound(vntName, 2)
vntResult(lngStart + (i - 1) * lngPitch + 1, 1) = vntName(1, i)
For j = 0 To UBound(vntTitle)
vntTmp = vntTitle(j)
Select Case j
Case 0, lngPitch - 1
vntTmp = Right(CStr(lngYear), 2) & vntTmp
Case lngPitch - 2
vntTmp = Right(CStr(lngYear - 1), 2) & vntTmp
End Select
vntResult(lngStart + (i - 1) * lngPitch + j + 1, 2) = vntTmp
Next j
Next i
With rngTop
'行見出しの出力
.Resize(UBound(vntResult, 1), 2).Value = vntResult
'列見出しの作成
ReDim vntResult(11)
For i = 0 To 11
vntResult(i) = ((i + 3) Mod 12 + 1) & "月"
Next i
.Offset(, 2).Resize(, UBound(vntResult) + 1).Value = vntResult
'算式の代入
For i = 1 To UBound(vntName, 2)
.Offset(lngStart + (i - 1) * lngPitch + 1, 2).Resize(, 12).FormulaR1C1 _
= "=IF(R[2]C="""","""",ROUND(R[-1]C/R[2]C,2))"
.Offset(lngStart + (i - 1) * lngPitch + 2, 2).Resize(, 12).FormulaR1C1 _
= "=IF(R[2]C="""","""",ROUND(R[-2]C/R[2]C,4))"
Next i
End With
End Sub
|
|
Hirofumi
- 07/5/21(月) 19:49 -
