| |
これでどうかな ? こちらのテストではうまくいったみたいですが。
Sub My集計()
Dim MyR As Range, C As Range
Dim i As Long, j As Long
Set Sh = Worksheets("Sheet2")
Application.ScreenUpdating = False
With Worksheets("Sheet1")
Set MyR = .Range("A10", .Range("A65536").End(xlUp)) _
.SpecialCells(2, 1)
For i = MyR.Areas.Count To 2 Step -1
MyR.Areas(i).EntireRow.Insert xlShiftDown
Next i
Set MyR = .Range("D10", .Range("D65536").End(xlUp)) _
.SpecialCells(2, 2)
End With
With Worksheets("Sheet2")
For Each C In MyR.Areas
i = .Range("B65536").End(xlUp).Row + 2
.Cells(i, 1).Value = _
Format(C.Range("A1").Offset(, -3).Value, "m月d日")
.Cells(i, 2).Resize(C.Count).Value = C.Value
.Cells(i, 3).Resize(C.Count).Value = _
C.Offset(, 3).Value
.Cells(i, 2).Resize(C.Count, 2).Sort Key1:= _
.Cells(i, 2), Order1:=xlAscending, Header:=xlYes, _
Orientation:=xlSortColumns
For j = (i + C.Count - 1) To (i + 2) Step -1
If .Cells(j, 2).Value = _
.Cells(j - 1, 2).Value Then
.Cells(j - 1, 3).Value = _
.Cells(j - 1, 3).Value + .Cells(j, 3).Value
.Rows(j).Delete xlShiftUp
End If
Next j
Next
.Rows("1:2").Delete xlShiftUp
.Activate
End With
With Worksheets("Sheet1")
.Range("D10", .Range("D65536").End(xlUp)) _
.SpecialCells(4).EntireRow.Delete xlShiftUp
End With
Application.ScreenUpdating = True: Set MyR = Nothing
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
