|
>空の行
は、C列にあるということでしょーか ? それならそこを埋めてしまわないと
うまくいきません。以下のように変更して下さい。
Sub MyData_Copy2()
Dim MyR As Range, C As Range
Dim GetR As Variant
Application.ScreenUpdating = False
On Error Resume Next
With Worksheets("A")
With .Range("C2", .Range("C65536").End(xlUp))
With .SpecialCells(4)
.FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With
On Error GoTo 0: If Err.Number <> 0 Then Err.Clear
With .Offset(, 26)
.Formula = "=IF($C1<>$C2,1,"""")"
.SpecialCells(3, 1).EntireRow.Insert xlShiftDown
.ClearContents
End With
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
|
|