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

 

[JoeRooney]

The second one is working for me, if gives that error but if I run again it will search will for staff id.

Thanks

 

[JLGWhiz]

The second one is working for me, if gives that error but if I run again it will search will for staff id.

When you click the debug button, which line of code is highlighted? Make sure all the items in the array are spelled correctly and that all entries in column A are exact matches for the array items.

 

[JoeRooney]

It is failing on Loop While fn.Address <> fAdr line , I don't think it is a spelling issue as when I stop the code and run again it works for Staff ID.

 

[JLGWhiz]

It is failing on Loop While fn.Address <> fAdr line , I don't think it is a spelling issue as when I stop the code and run again it works for Staff ID.

See if modifying that line to this:

Loop While fn.Address <> fAdr And Not fn Is Nothing

will fix it. This is just an attempt for a quick fix. I still cannot figure out why you are getting the error to begin with.

 

[JoeRooney]

Thanks but it still throws up the object variable or With block variable not set. Thank you for all your effort.

 

[JLGWhiz]

Thanks but it still throws up the object variable or With block variable not set. Thank you for all your effort.

OK, I cannot duplicate the error here. It runs as expected in test set up. You might be able to detect where the fn variable loses its value by opening the vb editor and click once anywhere inside the body of the macro. Then use the F8 key to step through the code. The line to be executed will be highlighted in yellow and that highlight will move to the next logical step each time you press the F8 key. You can use the mouse pointer to hover over the variables an the tool tips display will show the value of the variable after the execution of each line. Or you can open the immediate window and see the values there. That is a troubleshooting technique that I use when the error is not obvious. But I cannot do it for you from here.

 

[JoeRooney]

Staff ID
n/a
n/a
n/a
n/a
Date
n/a
n/a
n/a
Date
n/a
n/a
n/a
Rejected Staff No:
n/a
n/a
n/a
n/a
n/a

Column A in my spread sheet appears like above if that would help with the error. If not thank you for all your help.

 

[JLGWhiz]

Staff ID
n/a
n/a
n/a
n/a
Date
n/a
n/a
n/a
Date
n/a
n/a
n/a
Rejected Staff No:
n/a
n/a
n/a
n/a
n/a

Column A in my spread sheet appears like above if that would help with the error. If not thank you for all your help.

That is essetially how I set up the test data and it ran without error. You can do this to stop the error message, if it is actually copying the data over.

On Error Resume Next
Loop While fn.Address <> fAdr
If Err.Number > 0 Then Err.Clear
On Error GoTo 0

 

[JoeRooney]

Working now. Thank you for all your help , here is the final code

Sub FindData()
labelname1:

labelname: 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.Cut 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)

On Error GoTo labelname:


GoTo labelname1:



Loop While fn.Address <> fAdr
On Error GoTo labelname1:

del.EntireRow.Delete

Set fn = Nothing
Set del = Nothing

End If
Next
Call TidyUp
End Sub