VBA to cut active rows and paste into new sheet

[JoeRooney]

Hi,

I am new to VBA and having issues trying to cut and paste highlighted rows.

I have started with the below code but it only cuts the active cells rather than the entire rows , I have tried various different bits of code but can’t get anything to work.

I need the code to loop through sheet one, find and cut all rows with an offset of 3 for "Date", an offset of 4 for "Staff Id" and an offset of 5 for "Rejected Staff ID"

If anybody could help me with this Id greatly appreciate it.

Thanks,



Sub ErrorList()
'
Dim StartRange As String
Dim EndRange As String

Cells.Find(What:="Date").Select
StartRange = ActiveCell.Address
Selection.Offset(3, 0).Select
EndRange = ActiveCell.Address
ActiveSheet.Range(StartRange & ":" & EndRange).Select
Selection.Cut
Sheets("Sheet2").Select
ActiveSheet.Paste
Sheets("Sheet1").Select


Cells.Find(What:="Staff ID").Select
StartRange = ActiveCell.Address
Selection.Offset(4, 0).Select
EndRange = ActiveCell.Address
ActiveSheet.Range(StartRange & ":" & EndRange).Select
Selection.Cut
Sheets("Sheet2").Select
ActiveSheet.Paste

Cells.Find(What:="Rejected Staff No:").Select
StartRange = ActiveCell.Address
Selection.Offset(5, 0).Select
EndRange = ActiveCell.Address
ActiveSheet.Range(StartRange & ":" & EndRange).Select
Selection.Cut
Sheets("Sheet2").Select
ActiveSheet.Paste

End Sub

 

[JLGWhiz]

You have to tell it you want the whole row.

Selection.EntireRow.Cut

 

[JoeRooney]

Thank you , That worked.

 

[JoeRooney]

I am still having issues getting the code to loop through to find all matches and cut & paste into the next available empty row in sheet2 , would any one be able to assist with this?

Thanks,

 

[JLGWhiz]

I am still having issues getting the code to loop through to find all matches and cut & paste into the next available empty row in sheet2 , would any one be able to assist with this?

Thanks,

to create the proper loop, I would need to have a better understanding of your data layout. Are the target values of "Date", "Staff ID" and "Rejected Staff No:" randomly located in your worksheet, or are they in a single column (Which one?) or separate columns (Which ones?). Are there blank cells in any of the columns where the target values are located?

 

[JoeRooney]

Hi,

They are all located in column A , and I want all the dates rows plus an offset of 3 , then staff id rows with an offset of 4 and then finally Rejected Staff ID with an offset of 5 and to be moved to be moved to next available cell in column A in Sheet 2.

Thanks so much for your help.

 

[JLGWhiz]

Based on Post #6 , this is what I came up with.

Sub ErrorList2()
Dim sh1 As Worksheet, sh2 As Worksheet, fn As Range, fAdr As String, rng As Range, del As Range
 Set sh1 = Sheets("Sheet1")
 Set sh2 = Sheets("Sheet2")
 Set rng = sh1.Range("A2", sh1.Cells(Rows.Count, 1).End(xlUp))
 Set fn = rng.Find("Date", , xlValues, xlWhole)
    If Not fn Is Nothing Then
        fAdr = fn.Address
        Do
            fn.Resize(4).EntireRow.Copy sh2.Cells(Rows.Count, 2).End(xlUp)(2).Offset(, -1)
            If del Is Nothing Then
                Set del = fn.Resize(4)
            Else
                Set del = Union(del, fn.Resize(4))
            End If
            Set fn = rng.FindNext(fn)
        Loop While fn.Address <> fAdr
        del.EntireRow.Delete
        Set fn = Nothing
        Set del = Nothing
    End If
 Set fn = rng.Find("Staff ID", , xlValues, xlWhole)
    If Not fn Is Nothing Then
        fAdr = fn.Address
        Do
            fn.Resize(5).EntireRow.Copy sh2.Cells(Rows.Count, 2).End(xlUp)(2).Offset(, -1)
            If del Is Nothing Then
                Set del = fn.Resize(5)
            Else
                Set del = Union(del, fn.Resize(5))
            End If
            Set fn = rng.FindNext(fn)
        Loop While fn.Address <> fAdr
        del.EntireRow.Delete
        Set fn = Nothing
        Set del = Nothing
    End If
 Set fn = rng.Find("Rejected Staff No:", , xlValues, xlWhole)
    If Not fn Is Nothing Then
        fAdr = fn.Address
        Do
            fn.Resize(6).EntireRow.Copy sh2.Cells(Rows.Count, 2).End(xlUp)(2).Offset(, -1)
            If del Is Nothing Then
                Set del = fn.Resize(6)
            Else
                Set del = Union(del, fn.Resize(6))
            End If
            Set fn = rng.FindNext(fn)
        Loop While fn.Address <> fAdr
        del.EntireRow.Delete
        Set fn = Nothing
        Set del = Nothing
    End If
 End Sub

 

[JLGWhiz]

Here is a shorter version.

Sub ErrorList3()
Dim sh1 As Worksheet, sh2 As Worksheet, fn As Range, fAdr As String, rng As Range, del As Range
Dim ary As Variant
 Set sh1 = Sheets("Sheet1")
 Set sh2 = Sheets("Sheet2")
 ary = Array("Date", "Staff ID", "Rejected Staff No:")
 Set rng = sh1.Range("A2", sh1.Cells(Rows.Count, 1).End(xlUp))
 For i = LBound(ary) To UBound(ary)
 Set fn = rng.Find(ary(i), , xlValues, xlWhole)
    If Not fn Is Nothing Then
        fAdr = fn.Address
        Do
            fn.Resize(i + 4).EntireRow.Copy sh2.Cells(Rows.Count, 2).End(xlUp)(2).Offset(, -1)
            If del Is Nothing Then
                Set del = fn.Resize(i + 4)
            Else
                Set del = Union(del, fn.Resize(i + 4))
            End If
            Set fn = rng.FindNext(fn)
        Loop While fn.Address <> fAdr
        del.EntireRow.Delete
        Set fn = Nothing
        Set del = Nothing
    End If
Next
 End Sub

 

[JoeRooney]

Thanks so much , it's working perfect but before it moves to staff no it is giving me a object variable or with block variable not set error.

 

[JLGWhiz]

Thanks so much , it's working perfect but before it moves to staff no it is giving me a object variable or with block variable not set error.

Which one are you using?