| |
▼Hirofumi さん：
遅くなってすいません とりあえずupします
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 行, 列
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
With Worksheets("部門")
行 = Array(60, 63, 66, 81, 69, 93, 72, 75, 38, 214, 5, 41, 207, 20, 23, 8, 26, 29, 44, 47, 90, 50, 11, 14, 32, 136, 214, 84, 221, 96)
列 = Array(5, 8, 12, 15)
For i = 7 To 36
For j = 5 To 8
Worksheets("部門").Cells(行(i - 7), 列(j - 5)).Value = Worksheets("List2").Cells(i, j).Value
Next j
Next i
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
Range("E60").Value = Worksheets("List2").Range("E7").Valueでやると簡素化できないので変数使ってみることにしました。
不規則な行の変化で、配列がわからずつまずいていました
>>(10,13,26,27,29係）は本店にデーターなし（支店2内の部門)
ですのでとりあえず支店2を選択したときに出力したい行に抽出しました。
本店分だけですが、これでいいでしょうか？
この程度で時間かかってすいません。
|
|
hiro
- 07/6/14(木) 19:10 -
