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
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