|
ベタ書きですが
Sub MyData_Copy()
Dim MyR As Range, C As Range
Dim Ck As Variant
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
With Worksheets("A")
.Range("A1").Subtotal 1, xlCount, Array(2)
.Range("B:B").SpeclalCells(3).EntireRow.ClearContents
Set MyR = .Range("B:B").SpecialCells(2, 2)
End With
With Worksheets("総合")
For Each C In MyR.Areas
Ck = Application _
.Match(C.Range("A1").Value, .Range("C:C"), 0)
If IsError(Ck) Then
MsgBox C.Range("A1").Value & _
" の項目が見つかりません", 48
Else
C.Range("A1", C.Range("A1").End(xlDown)) _
.Copy .Cells(Ck + 1, 3)
End If
Next
End With
With Worksheets("A")
.Cells.RemoveSubtotal
.Range("A1", .Range("A65536").End(xlUp)) _
.SpecialCells(4).EntireRow.Delete xlShiftUp
End With
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
で、どうかな ?
|
|