| |
ちから技ですが、こちらのテストでは成功しました。
完成図を表示するシートの名前を "集計" とします。
Sub Data_集計()
Dim Sh As Worksheet, WS As Worksheet
Dim C As Range, FR As Range, MyR As Range
Dim Ary As Variant, MyV As Variant, V As Variant
Dim i As Long, Cnt As Long
Dim List() As String
Set Sh = Worksheets("集計")
Ary = Array("担当者", "得意先名", _
"売上金額１", "売上金額２", "売上金額３")
Application.ScreenUpdating = False
Sh.Cells.ClearContents
Sh.Range("A1:E1").Value = Ary
With Worksheets("Sheet3")
MyV = .Range("A2", .Range("A65536").End(xlUp)).Value
End With
Cnt = UBound(MyV): ReDim List(i): List(i) = "z"
For Each WS In Sheets(Array("Sheet1", "Sheet2", "Sheet3"))
For Each C In WS.Range("D2", WS.Range("D65536").End(xlUp))
If IsError(Application.Match(C.Value, List(), 0)) Then
i = i + 1: ReDim Preserve List(i)
List(i) = C.Value
End If
Next
Next
For Each V In List
If CStr(V) <> "z" Then
With Sh.Range("B65536").End(xlUp)
.Offset(2).Resize(Cnt).Value = MyV
.Offset(2, -1).Value = CStr(V)
End With
End If
Next
i = 1
For Each WS In Sheets(Array("Sheet1", "Sheet2", "Sheet3"))
For Each C In WS.Range("D2", WS.Range("D65536").End(xlUp))
xR = Application.Match(C.Value, Sh.Range("A:A"), 0)
Set FR = Sh.Cells(xR, 1).CurrentRegion _
.Find(C.Offset(, -3).Value, , xlValues)
If Not FR Is Nothing Then
FR.Offset(, i).Value = C.Offset(, -2).Value
Set FR = Nothing
End If
Next
i = i + 1
Next
Sh.Rows("2:2").Delete xlSiftUp
Set MyR = Sh.Range("B1", Sh.Range("B65536").End(xlUp).Offset(1)) _
.SpecialCells(4)
MyR.Offset(, -1).FormulaR1C1 = "=R[-" & Cnt & "]C&"" 計"""
Intersect(MyR.EntireRow, Sh.Range("C:E")).FormulaR1C1 = _
"=SUM(R[-" & Cnt & "]C:R[-1]C)"
Application.ScreenUpdating = True
Erase List: Set MyR = Nothing: Set Sh = Nothing
End Sub
|
|
Kein
- 06/8/18(金) 16:48 -
