Question

我有一个数据集，我需要剪切某些单元格并将其粘贴到它下面的后续行中。理想情况下，该代码将剪切并粘贴到其下面的所有行，然后在到达空白行时停止。在空白行之后，它将开始剪切并将下一数据行粘贴到其后续行并重复。我的数据看起来像这样。

Column A    Column B    Column C    Column D

123456789   QASD        School  
AWQTY192830 GHST        School      Car
AWQTY192830 GHST        School      Car
AWQTY192830 GHST        School      Car
AWQTY192830 GHST        School      Car

987654321   TWER        Work    
PWLRY437281 DFSW        Work        Bus
PWLRY437281 DFSW        Work        Bus

827361920   LOWP        Work    
QLAPT829183 POWE        Work        Bike

例如，我需要剪切并粘贴到单元格E4：E7中的单元格A3（这是一个9位数字），而剪切并粘贴到单元格F4：F7中的单元格B3。剪切/粘贴完成后，它将在下面的空白行处停止，然后从下一行开始输入数据并重复。

到目前为止我写的是什么

Sub cut_paste()

Dim nr As Integer
For nr = 1 To 195

If Len(Range("A" & nr)) = 9 Then

Range("A" & nr).Select
Selection.Cut
Range("N" & nr).Select
ActiveSheet.Paste
Range("B" & nr).Select
Selection.Cut

Range("O" & nr).Select
ActiveSheet.Paste

Next nr

End Sub

任何帮助将不胜感激。谢谢。

Answer 1

我建议以下内容：

Option Explicit

Public Sub CopyData()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Tabelle11") 'specify workbook

    Dim LastRow As Long
    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row 'find last used row

    Dim CopyRow As Long 'remember row where to copy from

    Dim iRow As Long
    For iRow = 1 To LastRow
        If Len(ws.Cells(iRow, "A")) = 9 Then 'if number then remember copyrow
            CopyRow = iRow
        ElseIf Len(ws.Cells(iRow, "A")) > 0 And CopyRow > 0 Then 'if not a empty line then paste
            ws.Cells(iRow, "E").Value = ws.Cells(CopyRow, "A").Value
            ws.Cells(iRow, "F").Value = ws.Cells(CopyRow, "B").Value
        End If
    Next iRow
End Sub

或者如果要删除复制的行，则执行以下操作：

Option Explicit

Public Sub CopyData()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Tabelle11") 'specify workbook

    Dim LastRow As Long
    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row 'find last used row

    Dim CopyRow As Long 'remember row where to copy from
    Dim RowsToDelete As Range

    Dim iRow As Long
    For iRow = 1 To LastRow
        If Len(ws.Cells(iRow, "A")) = 9 Then 'if number then remember copyrow
            CopyRow = iRow
            If RowsToDelete Is Nothing Then 'remember which rows we want to delete in the end.
                Set RowsToDelete = ws.Rows(CopyRow)
            Else
                Set RowsToDelete = Union(RowsToDelete, ws.Rows(CopyRow))
            End If
        ElseIf Len(ws.Cells(iRow, "A")) > 0 And CopyRow > 0 Then 'if not a empty line then paste
            ws.Cells(iRow, "E").Value = ws.Cells(CopyRow, "A").Value
            ws.Cells(iRow, "F").Value = ws.Cells(CopyRow, "B").Value
        End If
    Next iRow

    RowsToDelete.Delete
End Sub

剪切并粘贴特定的数据行

1 个答案: