search all rows and columns in sheet1 for string, copy entire row to sheet2 if found

Question

How would I search all rows and columns in sheet1 for a particular string, then copy entire row to sheet2 if found, without creating duplicates?

Here's what I have so far based upon this answer but I believe I need to loop this for all columns. This is just searching the first column A.

Sub Main()
   Dim wb1 As Workbook
   Set wb1 = ThisWorkbook

   Call searchtext("organic", "Organic Foods")
   wb1.Save

End Sub


Private Sub searchtext(term, destinationsheet)
    Dim wb1 As Workbook
    Set wb1 = ThisWorkbook
    Dim ws1 As Worksheet
    Set ws1 = wb1.Sheets(1) 'assumes raw data is always first sheet
    Dim ws2 As Worksheet
    Dim copyFrom As Range
    Dim lRow As Long 

    With ws1

        .AutoFilterMode = False

        lRow = .Range("A" & .Rows.Count).End(xlUp).Row
        With .Range("A1:A" & lRow)
            .AutoFilter Field:=1, Criteria1:="=*" & term & "*"
            Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
        End With

        .AutoFilterMode = False
    End With

    '~~> Destination File
    Set ws2 = wb1.Worksheets(destinationsheet)

    ws2.Cells.ClearContents

    With ws2
        If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
            lRow = .Cells.Find(What:="*", _
                          After:=.Range("A1"), _
                          Lookat:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Row
        Else
            lRow = 1
        End If

        copyFrom.Copy .Rows(lRow)
    End With


End Sub

And when I try to loop out then dedupe, the code below only compares the first two columns. How do I specify all columns to compare for duplicates?

Private Sub RemoveDuplicates(destinationsheet) 
    Dim wb1 As Workbook
    Set wb1 = ThisWorkbook

    With wb1.Worksheets(destinationsheet)
        Set Rng = Range("A1", Range("B1").End(xlDown))
        Rng.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
    End With

End Sub

score 2 · Accepted Answer · edited Jan 15 '15 at 21:41

I've rewritten your first code to loop through all available columns. I did not test this code on multiple worksheets but it does compile.

Private Sub searchtext(term, destinationsheet)
    Dim wb1 As Workbook, ws1 As Worksheet, ws2 As Worksheet
    Dim copyFrom As Range, c As Long, lr As Long, b1st As Boolean

    Set wb1 = ThisWorkbook
    Set ws1 = wb1.Worksheets(1) 'assumes raw data is always first sheet
    Set ws2 = wb1.Worksheets(destinationsheet)
    ws2.Cells.ClearContents

    With ws1.Cells(1, 1).CurrentRegion
        .Parent.AutoFilterMode = False
        lr = .Rows.Count
        For c = 1 To .Columns.Count
            b1st = CBool(Application.CountA(ws2.Columns(1)))
            .AutoFilter
            .Columns(c).AutoFilter Field:=1, Criteria1:="=*" & term & "*"
            If CBool(Application.Subtotal(103, .Columns(c))) Then _
                .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Copy _
                    Destination:=ws2.Cells(Rows.Count, 1).End(xlUp).Offset(0 - b1st, 0)
        Next c

        .Parent.AutoFilterMode = False
    End With

    Set ws2 = Nothing
    Set ws1 = Nothing
    Set wb1 = Nothing
End Sub

As to your remove duplicates issue, use .CurrentRegion to govern the area being considered and construct an array to use in the Columns:= parameter.

Public Sub RemoveDuplicates(destinationsheet)
    Dim a As Long, rdCOLs As Variant
    Dim wb1 As Workbook
    Set wb1 = ThisWorkbook

    With wb1.Worksheets(destinationsheet)
        With .Cells(1, 1).CurrentRegion
            ReDim rdCOLs(.Columns.Count - 1)
            For a = LBound(rdCOLs) To UBound(rdCOLs)
                rdCOLs(a) = a + 1
            Next a
            .RemoveDuplicates Columns:=(rdCOLs), Header:=xlYes
        End With
    End With

    Set wb1 = Nothing
End Sub

The brackets around rdCOLs in Columns:=(rdCOLs), are IMPORTANT. Without them, the array is not processed by the .RemoveDuplicates command. This code was tested on Excel 2010.

That solved it, thanks so much for the detailed response. I went through the updates you made and learned a bunch! — utt73, Jan 15 '15 at 21:22

search all rows and columns in sheet1 for string, copy entire row to sheet2 if found

1 Answers1