我有一个数据集,我需要将某些单元格剪切并粘贴到它下面的后续行中。理想情况下,该代码将剪切并粘贴到其下方的所有行,然后在到达空白行时停止。在空白行之后,它将开始剪切下一行数据并将其粘贴到其后续行并重复。我的数据看起来像这样。
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
任何帮助是极大的赞赏。谢谢。
最佳答案
我建议如下:
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
关于vba - 剪切粘贴某行数据,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/51593547/