| |
修正で間違えるといけないので、変更のない「Private Sub DoFilter」以外をUpします
尚、コメントは、Up出来る行数を超えるといけないので削除して有ります
Public Sub Main2()
'◆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 rngOther As Range
Dim vntItem As Variant
Dim vntCPos As Variant
Dim vntRPos As Variant
Dim strProm As String
'◆Listの先頭セル位置を基準とする（列見出し「日付」のセル位置）
Set rngList = Worksheets("List").Cells(1, "A")
'◆List2の先頭セル位置を基準とする（列見出し「店舗」のセル位置）
Set rngResult = Worksheets("List2").Cells(5, "B")
Application.ScreenUpdating = False
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
.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
'◆「項目」列の抽出条件文字列を設定
vntItem = Array("売上", "差益", "仕入", "在庫")
'◆累計を転記する別シートの位置
vntCPos = Array(2, 5, 9, 12)
'◆部門データの転記行位置を設定
Select Case vntKeyB1
Case "本店"
Set rngOther = Worksheets("部門").Cells(4, "C")
vntRPos = Array(56, 59, 62, 77, 65, 89, 68, 71, 34, "", _
1, 37, "", 16, 19, 4, 22, 25, 40, 43, _
86, 46, 7, 10, 28, "", "", 80, "", 92)
Case "支店A"
Set rngOther = Worksheets("部門").Cells(118, "C")
vntRPos = Array(56, 59, "", "", 68, "", 62, 31, 34, "", _
13, 1, "", "", "", "", 16, 19, 47, 4, _
"", 50, 37, 7, "", "", "", 22, "", 25)
Case "支店B"
Set rngOther = Worksheets("部門").Cells(208, "C")
vntRPos = Array("", "", "", "", "", "", "", "", "", 4, _
"", "", 1, "", "", "", "", "", "", "", _
"", "", "", "", "", "", 7, "", 13, "")
End Select
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, vntItem, _
rngOther, vntCPos, vntRPos) Then
GoTo Wayout
End If
If Not AddUp(rngList, rngResult.Offset(, 10), rngWork, vntKeyA2, _
vntKeyB1, clngColumns, clngItem, vntItem, _
rngOther.Offset(1), vntCPos, vntRPos) 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
Set rngOther = 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, _
vntItem As Variant, _
Optional rngOther As Range, _
Optional vntCPos As Variant, _
Optional vntRPos As Variant) 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
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))
.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) & """"
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
.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
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
Application.Intersect(.CurrentRegion, _
.CurrentRegion.Offset(, 1)).Copy
End With
With rngResult
.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
If (Not rngOther Is Nothing) _
And VarType(vntRPos) = vbArray + vbVariant Then
For i = UBound(vntCPos) To 0 Step -1
If vntCPos(i) <> "" Then
For j = 0 To UBound(vntRPos)
If vntRPos(j) <> "" Then
rngOther.Offset(vntRPos(j), vntCPos(i)).Value _
= .Offset(j + 2, lngRows + i).Value
End If
Next j
End If
Next i
End If
.Parent.Activate
.Select
End With
End Function
|
|
Hirofumi
- 07/6/18(月) 12:16 -
