I have a data set and I needed certain cells cut and pasted to the subsequent rows below it. The code would ideally cut and paste to all rows below it and then stop once it reaches a blank row. After the blank row, it would begin cut and pasting the next row of data to its subsequent rows and repeat. My data looks like this.
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
What I need, for example, is cell A3 (this is a 9-digit number) to be cut and pasted in cell E4:E7 and cell B3 cut and pasted into cell F4:F7. After it’s done cut/pasting, it would stop at the blank row below and then start at the next row with data and repeat.
What i’ve written so far:
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
Any help is greatly appreciated. Thanks.
I suggest the following:
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
Or the following if the rows that you copied from should be deleted:
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
Tags: excelexcel
