Moving rows to new sheet issue executing

scarrain

New Member
Joined
Jan 22, 2021
Messages
4
Office Version
  1. 2013
Platform
  1. Windows
I have a file with multiple tabs one is called DATA where I reference lists another is called Reports, what I need is for the macro to take rows from Reports reference cells in DATA and if it is found move them to an existing sheet. I found this code, unable to give credit to the author cause I can't locate it again, that does what I need it to do I changed the worksheet names to fit my tabs, when I click the button the code looks at column AE on the tab Reports and then references cell C2 on the DATA tab and moves it to the tab called HOLD. The bolded section is the original code I then repeated the code four more times to account for cells C2 thru C5 which also has data that needs to move to the HOLD tab. In its current configuration the code works the way I need it to when I click the button but it's a bit slow. I did attempt to add it as a range C2:C5 but it would not execute in that format if there is a way to clean it up to make it run more efficiently I would appreciate any assistance.

The major issue that I have is I need it to move rows to tabs other than HOLD but I'm unable to run it using any other data. SEE NON-FUNCTION CODE below.

Any assistance would be appreciated.

Sub HOLD()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("Report").UsedRange.Rows.Count
J = Worksheets("HOLD").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("HOLD").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Report").Range("AE1:AE" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Worksheets("DATA").Range("C2") Then
xRg(K).EntireRow.Copy Destination:=Worksheets("HOLD").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = Worksheets("DATA").Range("C2") Then
K = K - 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True

I = Worksheets("Report").UsedRange.Rows.Count
J = Worksheets("HOLD").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("HOLD").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Report").Range("AE1:AE" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Worksheets("DATA").Range("C2") Then
xRg(K).EntireRow.Copy Destination:=Worksheets("HOLD").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = Worksheets("DATA").Range("C2") Then
K = K - 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True
I = Worksheets("Report").UsedRange.Rows.Count
J = Worksheets("HOLD").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("HOLD").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Report").Range("AE1:AE" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Worksheets("DATA").Range("C3") Then
xRg(K).EntireRow.Copy Destination:=Worksheets("HOLD").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = Worksheets("DATA").Range("C3") Then
K = K - 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True
I = Worksheets("Report").UsedRange.Rows.Count
J = Worksheets("HOLD").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("HOLD").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Report").Range("AE1:AE" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Worksheets("DATA").Range("C4") Then
xRg(K).EntireRow.Copy Destination:=Worksheets("HOLD").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = Worksheets("DATA").Range("C4") Then
K = K - 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True
I = Worksheets("Report").UsedRange.Rows.Count
J = Worksheets("HOLD").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("HOLD").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Report").Range("AE1:AE" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Worksheets("DATA").Range("C5") Then
xRg(K).EntireRow.Copy Destination:=Worksheets("HOLD").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = Worksheets("DATA").Range("C5") Then
K = K - 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True
I = Worksheets("Report").UsedRange.Rows.Count
J = Worksheets("HOLD").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("HOLD").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Report").Range("AE1:AE" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Worksheets("DATA").Range("C6") Then
xRg(K).EntireRow.Copy Destination:=Worksheets("HOLD").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = Worksheets("DATA").Range("C6") Then
K = K - 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub


NON-FUNCTION CODE BELOW (NMCS)

Sub NMCS()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("Report").UsedRange.Rows.Count
J = Worksheets("NMCS").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("NMCS").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Report").Range("AN1:AN" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Worksheets("DATA").Range("C8") Then
xRg(K).EntireRow.Copy Destination:=Worksheets("NMCS").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = Worksheets("DATA").Range("C8") Then
K = K - 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
 

Excel Facts

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college

Forum statistics

Threads
1,215,066
Messages
6,122,947
Members
449,095
Latest member
nmaske

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top