Copying rows to new sheet with search function

[Srelie]

I am new to VBA and am in need of some help.

My goal is to copy rows to a new sheet, based on a search from a set list.

I found a macro via a google search earlier and tried to modify it to my needs, but I'm not competent enough yet.

Sub Search()
  'If value in column B = Matches anything in column G, copy entire row to Sheet2
  Dim searchTerm As String
  For I = 1 To 1130
      searchTerm = ActiveSheet.Range("G" & I).Text
      If ActiveSheet.Range("B" & CStr(LSearchColumn)).Value = searchTerm Then
         'Select row in Sheet1 to copy
         Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
         Selection.Copy
         'Paste row into Sheet2 in next row
         Sheets("Sheet2").Select
         Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
         ActiveSheet.Paste
         'Move counter to next row
         LCopyToRow = LCopyToRow + 1
         'Go back to Sheet1 to continue searching
         Sheets("Sheet1").Select
      End If
Next I
End Sub

I'm getting this error: Run-time error '1004'


Thank you.

 

[Srelie]

I sent you a PM.

 

[JoeMo]

I sent you a PM.

Got it, but before we go any farther I would like you to try this revision on your original workbook (the one you first tried and responded about an error in post #13). It just dawned on me that you probably have sufficient matches to generate a string of addresses that exceeds a VBA length limit for a range specification. This revision should overcome that problem. If not go ahead and mail me your workbook.

Sub Srelie()
Dim Sh1 As Worksheet, Sh2 As Worksheet, Rs As Range, Rg As Range, Vs As Variant, Vg As Variant, Rc As Range
Dim i As Long, j As Long, nxRw As Long
Set Sh1 = ActiveSheet
Set Sh2 = Sheets("sheetPaste")
With Sh1
    Set Rs = .Range("A1").CurrentRegion
    Vs = Rs.Value
    Set Rg = .Range("G1:G" & .Cells(.Rows.Count, "G").End(xlUp).Row)
    Vg = Rg.Value
End With
For i = 1 To UBound(Vg, 1)
    For j = 1 To UBound(Vs, 1)
        If Vs(j, 2) Like "*" & Vg(i, 1) & "*" Then
            If Rc Is Nothing Then
                Set Rc = Sh1.Rows(j)
            Else
                Set Rc = Union(Rc, Sh1.Rows(j))
            End If
        End If
    Next j
Next i
If Not Rc Is Nothing Then
    Application.ScreenUpdating = False
    nxRw = IIf(IsEmpty(Sh2.Range("A1")), 1, Sh2.Cells(Rows.Count, "A").End(xlUp).Row + 1)
    Rc.Copy Destination:=Sh2.Rows(nxRw)
    Application.CutCopyMode = False
    Sh2.Columns("A:D").AutoFit
Else
    MsgBox "no matches of col G items found in col B"
End If
Application.ScreenUpdating = True
End Sub

 

[Srelie]

Got it, but before we go any farther I would like you to try this revision on your original workbook (the one you first tried and responded about an error in post #13). It just dawned on me that you probably have sufficient matches to generate a string of addresses that exceeds a VBA length limit for a range specification. This revision should overcome that problem. If not go ahead and mail me your workbook.

Sub Srelie()
Dim Sh1 As Worksheet, Sh2 As Worksheet, Rs As Range, Rg As Range, Vs As Variant, Vg As Variant, Rc As Range
Dim i As Long, j As Long, nxRw As Long
Set Sh1 = ActiveSheet
Set Sh2 = Sheets("sheetPaste")
With Sh1
    Set Rs = .Range("A1").CurrentRegion
    Vs = Rs.Value
    Set Rg = .Range("G1:G" & .Cells(.Rows.Count, "G").End(xlUp).Row)
    Vg = Rg.Value
End With
For i = 1 To UBound(Vg, 1)
    For j = 1 To UBound(Vs, 1)
        If Vs(j, 2) Like "*" & Vg(i, 1) & "*" Then
            If Rc Is Nothing Then
                Set Rc = Sh1.Rows(j)
            Else
                Set Rc = Union(Rc, Sh1.Rows(j))
            End If
        End If
    Next j
Next i
If Not Rc Is Nothing Then
    Application.ScreenUpdating = False
    nxRw = IIf(IsEmpty(Sh2.Range("A1")), 1, Sh2.Cells(Rows.Count, "A").End(xlUp).Row + 1)
    Rc.Copy Destination:=Sh2.Rows(nxRw)
    Application.CutCopyMode = False
    Sh2.Columns("A:D").AutoFit
Else
    MsgBox "no matches of col G items found in col B"
End If
Application.ScreenUpdating = True
End Sub

This worked perfectly. Thanks a ton!

 

[JoeMo]

This worked perfectly. Thanks a ton!

You are welcome - thanks for the reply.