剪切粘贴某行数据

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

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

到目前为止我写的：

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