| |
こんなかな？
Option Explicit
Public Sub Main()
'◆Listのデータ列数（A列〜AG列）
Const clngColumns As Long = 33
'◆「日付」の列位置を指定(基準セル位置からの列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 lngRows As Long
Dim rngList As Range
Dim rngResult As Range
Dim rngWork As Range
Dim vntKeyA1 As Variant
Dim vntKeyA2 As Variant
Dim vntKeyB1 As Variant
Dim strProm As String
'◆Listの先頭セル位置を基準とする（列見出し「日付」のセル位置）
Set rngList = Worksheets("List").Cells(1, "A")
'◆List2の先頭セル位置を基準とする（列見出し「店舗」のセル位置）
Set rngResult = Worksheets("List2").Cells(5, "B")
With rngList
'行数の取得
lngRows = .CurrentRegion.Rows.Count - 1
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
End With
With rngResult
'「日付」の抽出条件を取得
vntKeyA1 = .Parent.Cells(2, 2).Value
vntKeyA2 = .Parent.Cells(2, 3).Value
'「店舗」の抽出条件を取得
vntKeyB1 = .Parent.Cells(3, 2).Value
'先回の結果をクリア (結果表示先List2のA:AF)
.CurrentRegion.ClearContents
End With
'日付の確認
strProm = "抽出日付が、日付と認められません"
If Not IsDate(Left(vntKeyA1, 4) _
& "/" & Mid(vntKeyA1, 5, 2) _
& "/" & Right(vntKeyA1, 2)) Then
GoTo Wayout
End If
If Not IsDate(Left(vntKeyA2, 4) _
& "/" & Mid(vntKeyA2, 5, 2) _
& "/" & Right(vntKeyA2, 2)) Then
GoTo Wayout
End If
'画面更新を停止
' Application.ScreenUpdating = False
'作業用シートを追加
With Worksheets
Set rngWork = .Add(After:=.Item(.Count)).Cells(1, "A")
End With
With rngWork
'列見出しを貼り付け
rngList.Resize(, clngColumns).Copy Destination:=.Item(1)
'AdvancedFilter条件範囲の列見出しの出力
With .Offset(, clngColumns)
.Offset(, 1).Resize(, 2).Value _
= rngList.Offset(, clngDate).Value
.Offset(, 3).Value = rngList.Offset(, clngKey).Value
.Offset(, 4).Value = rngList.Offset(, clngItem).Value
End With
End With
strProm = "抽出条件に一致するレコードが有りません"
If Not AddUp(rngList, rngResult, _
rngWork, vntKeyA1, vntKeyB1, clngColumns, clngItem) Then
GoTo Wayout
End If
If Not AddUp(rngList, rngResult.Offset(, 10), _
rngWork, vntKeyA2, vntKeyB1, clngColumns, clngItem) Then
GoTo Wayout
End If
strProm = "処理が完了しました"
Wayout:
'作業シートを削除
If Not rngWork Is Nothing Then
Application.DisplayAlerts = False
rngWork.Parent.Delete
Application.DisplayAlerts = True
End If
'画面更新を再開
Application.ScreenUpdating = True
Set rngWork = Nothing
Set rngList = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
Private Function AddUp(rngList As Range, rngResult As Range, _
rngWork As Range, vntKeyA1 As Variant, _
vntKeyB1 As Variant, lngColumns As Long, _
lngItem As Long) As Boolean
'◆「1係」の列位置を指定(基準セル位置からの列Offset：基準がA1で「1係」がD列なら3)
Const clngBegin As Long = 3
Dim i As Long
Dim j As Long
Dim lngRows As Long
Dim vntResult As Variant
Dim vntTop As Variant
Dim vntItem As Variant
'◆「項目」列の抽出条件文字列を設定
vntItem = Array("売上", "差益", "仕入", "在庫")
'年度先頭の日付を取得
vntTop = Left(vntKeyA1, 4) & "/" & Mid(vntKeyA1, 5, 2) _
& "/" & Right(vntKeyA1, 2)
'年度を調整
vntTop = DateValue(vntTop)
vntTop = ">=" & Format(DateSerial(Year(vntTop), _
Month(vntTop), 1), "yyyymmdd")
AddUp = True
With rngWork
'集計結果の格納用配列を確保
ReDim vntResult(UBound(vntItem))
'☆KeyA1の値以下の日付で、KeyB1の店舗で
'日付条件を出力
.Offset(1, lngColumns + 1).Value = vntTop
.Offset(1, lngColumns + 2).Value = "<=" & vntKeyA1
'店舗条件を出力
.Offset(1, lngColumns + 3).Resize(UBound(vntItem) + 1).Value _
= "=" & """=" & vntKeyB1 & """"
'売上、差益を抽出し、集計
For i = 0 To UBound(vntItem)
'項目条件を出力
.Offset(1, lngColumns + 4).Value _
= "=" & """=" & vntItem(i) & """"
'AdvancedFilterを実行
DoFilter rngList.CurrentRegion, .Offset(, lngColumns + 1) _
.Resize(2, 4), .Resize(, lngColumns)
'データ行数を取得
lngRows = .CurrentRegion.Rows.Count
'売上データを集計
With .Offset(lngRows, clngBegin).Resize(, lngColumns - clngBegin)
'範囲に関数を設定
.FormulaR1C1 = "=Sum(R[-" & (lngRows - 1) & "]C:R[-1]C)"
End With
'範囲を配列に取得
vntResult(i) = .Offset(lngRows).Resize(, lngColumns).Value
vntResult(i)(1, lngItem + 1) = vntItem(i) & "累計"
Next i
'☆KeyA1の値の日付で、KeyB1の店舗のデータを抽出
'日付条件を出力
.Offset(1, lngColumns + 2).Resize( _
UBound(vntItem) + 1).Value = vntKeyA1
For i = 0 To UBound(vntItem)
.Offset(1 + i, lngColumns + 4).Value _
= "=" & """=" & vntItem(i) & """"
Next i
'AdvancedFilterを実行
DoFilter rngList.CurrentRegion, .Offset(, lngColumns + 2) _
.Resize(UBound(vntItem) + 1 + 1, 3), .Resize(, lngColumns)
'データ行数を取得
lngRows = .CurrentRegion.Rows.Count
'抽出データがない場合
If lngRows = 1 Then
AddUp = False
rngResult.Parent.Activate
Exit Function
End If
'抽出項目の整列
vntTop = .Offset(1, lngItem).Resize(lngRows).Value
For i = 1 To lngRows - 1
For j = 0 To UBound(vntItem)
If vntTop(i, 1) = vntItem(j) Then
vntTop(i, 1) = j
Exit For
End If
Next j
Next i
.Offset(1, lngColumns).Resize(lngRows - 1).Value = vntKeyB1
.Offset(1).Resize(lngRows - 1, lngColumns + 1).Sort _
Key1:=.Offset(1, lngColumns), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlStroke
.Offset(1, lngColumns).EntireColumn.ClearContents
'売上、差益データを出力
For i = 0 To UBound(vntItem)
.Offset(lngRows + i).Resize(, _
lngColumns).Value = vntResult(i)
Next i
'結果範囲をCopy
Application.Intersect(.CurrentRegion, _
.CurrentRegion.Offset(, 1)).Copy
End With
With rngResult
'出力結果の下に行列を入れ替え値のみPaste
.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
.Parent.Activate
.Select
End With
End Function
Private Sub DoFilter(rngScope As Range, _
rngCriteria As Range, _
rngCopyTo As Range)
' AdvancedFilterの実行
rngScope.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=rngCriteria, _
CopyToRange:=rngCopyTo, _
Unique:=False
End Sub
|
|
Hirofumi
- 07/6/11(月) 2:49 -
