0

私はこのコードを持っています（動作しています）。

Sub Copy_Ten()
 Dim X As Long, LastRow As Long
 Dim CopyRange As Range
 LastRow = Cells(Cells.Rows.Count, "A").End(xlUp).Row
 For X = 1 To LastRow Step 4
     If CopyRange Is Nothing Then
         Set CopyRange = Rows(X).EntireRow
     Else
         Set CopyRange = Union(CopyRange, Rows(X).EntireRow)
     End If
 Next
 If Not CopyRange Is Nothing Then
 CopyRange.Copy Destination:=Sheets("Sheet2").Range("A1")
 End If
 End Sub

シート2では、常にA1から始まります。次のスペースを探して続けてほしいです。

私が持っているコードは、Range("A1").End(xldown).Selectしかし、それをどこに置くべきかわかりません。

したがって、最終的にシート2は、A1から初めて開始した後は、リストが増えることはありません。

4

1 に答える 1

1

そのコードを使用できますが、そのような関数でラップします

With Sheets("Sheet2")
    lastRow2 = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

次に変更します

CopyRange.Copy Destination:=Sheets("Sheet2").Range("A1")

に

CopyRange.Copy Destination:=Sheets("Sheet2").Range("A" & lastRow2)

これをもう少し明確にするには、次のことを試してください

Sub Copy_Ten()
    Dim X As Long, LastRow As Long, PasteRow As Long
    Dim CopyRange As Range
    LastRow = Cells(Cells.Rows.Count, "A").End(xlUp).Row
    With Sheets("Sheet2")
        PasteRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With
    For X = 1 To LastRow Step 4
        If CopyRange Is Nothing Then
            Set CopyRange = Rows(X).EntireRow
        Else
            Set CopyRange = Union(CopyRange, Rows(X).EntireRow)
        End If
    Next
    If Not CopyRange Is Nothing Then
        CopyRange.Copy Destination:=Sheets("Sheet2").Range("A" & PasteRow)
    End If
End Sub
于 2013-02-11T00:53:12.813 に答える