|
仮に Sheet1 にその表があるとして、Sheet2 に集計した表を作ります。
ただし、集計先では元表の日付の上にあった空白行は、詰めて表示します。
コードはこんな感じになります。シートの指定については、そちらで適当に
修正して下さい。
Sub MyTable()
Dim MyR As Range, C As Range, HdR As Range
Dim Cnt As Long
Application.ScreenUpdating = False
With Sheets("Sheet1")
.Rows(1).Insert xlShiftDown
Set MyR = .Range("B1", Range("B65536").End(xlUp)) _
.SpecialCells(2)
End With
With Sheets("Sheet2")
For Each C In MyR.Areas
Cnt = C.Cells.Count
Set HdR = C.Cells(1).Offset(-1)
HdR.Value = "Data"
HdR.Resize(Cnt + 1).AdvancedFilter xlFilterCopy, , _
.Range("B65536").End(xlUp).Offset(2), True
With .Range("B65536").End(xlUp).CurrentRegion
.Offset(, 1).Formula = _
"=SUMIF(Sheet1!" & C.Address & "," & _
.Cells(1).Address(0, 0) & "," & "Sheet1!" & _
C.Offset(, 1).Address & ")"
With .Cells(1)
.Offset(1, -1).Value = _
C.Cells(1).Offset(, -1).Value
.Resize(, 2).ClearContents
End With
End With
HdR.ClearContents: Set HdR = Nothing
Next
With .Range("C1", .Range("C65536").End(xlUp))
.Copy
.PasteSpecial xlPasteValues
.SpecialCells(4).EntireRow.Delete xlShiftUp
End With
.Activate
.Range("A1").Activate
End With
Set MyR = Nothing
Sheets("Sheet1").Rows(1).Delete xlShiftUp
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
End Sub
|
|