|
すいません遅くなりましたが、集計機能による分割を止めて数式でやってみます。
Sub MyData_Copy2()
Dim MyR As Range, C As Range
Dim GetR As Variant
Application.ScreenUpdating = False
With Worksheets("A")
With .Range("C2", .Range("C65536").End(xlUp)).Offset(, 26)
.Formula = "=IF($C1<>$C2,1,"""")"
.SpecialCells(3, 1).EntireRow.Insert xlShiftDown
.ClearContents
End With
Set MyR = .Range("C1", .Range("C65536").End(xlUp)) _
.Offset(, 4).SpecialCells(2)
End With
With Worksheets("総合")
For Each C In MyR.Areas
GetR = Application _
.Match(C.Range("A1").Value, .Range("H:H"), 0)
If Not IsError(GetR) Then
C.Copy .Cells(GetR, 8)
End If
Next
End With
With Worksheets("A")
.Range("C1", .Range("C65536").End(xlUp)).SpecialCells(4) _
.EntireRow.Delete xlShiftUp
End With
Application.ScreenUpdating = True: Set MyR = Nothing
End Sub
|
|