Search Functions‎ > ‎

Multi-FIND-Copy

PROBLEM:
"I would like a VBA macro script to pop-up a search form to search for multiple text strings within a database on Sheet1.  Any cells containing any of the searched strings...the entire row is copied to Sheet2."
 
PROBLEM2:
"I would like a VBA macro script to pop-up a search form to search for multiple text strings within a database on Sheet1. Any cells containing ALL of the searched strings...the entire row is copied to Sheet2."
 

SPECIFICATIONS:
  1. Strings are partial strings, not entire cell values
  2. Entire rows are copied
  3. As many strings can be searched as wanted, macro finishes and copies when the user CANCELs a search request
  4. Regardless of how many times one row is found through multiple searches, a row is only copied once at the end
  5. The rows copied after ALL the strings are searched appear on sheet2 in the original order they were on sheet1.
  6. Macro is dynamic and should work with a database with thousands of rows and many columns.
  7. Sheet2 already has a header in row1, so data is pasted into row2 each time macro runs, or added to the current sheet2 data

                                                        Sample Workbook:    MultiFINDCopy.xls       or       MultiFindCopy.xlsm

                There are two macros:
                          MultiFINDCopy - finds all rows that have any of the search strings entered
                          MultiMATCHCopy - finds rows that only have all of the search strings entered

CODE

Option Explicit

Sub MultiFindCopy()
'Author:    Jerry Beaucaire
'Date:      8/19/2010
'Summary:   Prompt for search strings, copy all rows that match the strings
'           anywhere to a second sheet for review
'           3/10/2011 added ability to search specific column only
Dim findRNG As Range    'found rows to be copied all at once at the end
Dim vFind   As Range
Dim vFirst  As Range
Dim vStr    As String   'string to find
Dim vCol    As Long     'column to search

'set this to the column number to search. Use 0 to search all columns
vCol = 6    'in this example, 5 = column F

On Error Resume Next
vStr = Application.InputBox("String to search for:", "Search Data", Type:=2)
With Sheets("Sheet1")
    Do
        If vStr = "False" Then Exit Do
        If vCol = 0 Then
            Set vFind = .Cells.Find(What:=vStr, LookIn:=xlFormulas, LookAt:=xlPart)
        Else
            Set vFind = .Columns(vCol).Find(What:=vStr, LookIn:=xlFormulas, LookAt:=xlPart)
        End If
        If Not vFind Is Nothing Then
            Set vFirst = vFind
            Do
                If findRNG Is Nothing Then Set findRNG = vFind _
                    Else Set findRNG = Union(findRNG, vFind)
                If vCol = 0 Then
                    Set vFind = .Cells.FindNext(vFind)
                Else
                    Set vFind = .Columns(vCol).FindNext(vFind)
                End If
            Loop Until vFind.Address = vFirst.Address
            Set vFind = Nothing
            Set vFirst = Nothing
        End If
        vStr = Application.InputBox("Next String to search for:", "Search Data", Type:=2)
    Loop
End With

If findRNG Is Nothing Then
    MsgBox "Nothing found to copy."
    Exit Sub
End If
    
With Sheets("Sheet2")
    If MsgBox("Clear previous data?", vbYesNo, "Reset?") = vbYes Then
        .Range("A2:A" & .Rows.Count).EntireRow.Clear
        findRNG.EntireRow.Copy .Range("A2")
    Else
        findRNG.EntireRow.Copy .Range("A" & .Rows.Count).End(xlUp).Offset(1)
    End If
End With

Set findRNG = Nothing
Sheets("Sheet2").Activate
End Sub
 

CODE

Option Explicit

Sub MultiMatchCopy()
'Author:    Jerry Beaucaire
'Date:      8/19/2010
'Summary:   Prompt for search strings, copy all rows that match the strings
'           anywhere to a second sheet for review
'           3/10/2011 added ability to search specific column only
'           7/19/2012 created multi MATCH version requires all strings match

Dim findRNG As Range    'found rows that matched all search values, copied all at once at the end
Dim tempRNG As Range    'found rows for current search value only
Dim vFind   As Range
Dim vFirst  As Range
Dim vStr    As String   'string to find
Dim vCol    As Long     'column to search

'set this to the column number to search. Use 0 to search all columns
vCol = 6    'in this example, 5 = column F

On Error Resume Next
vStr = Application.InputBox("String to search for:", "Search Data", Type:=2)
With Sheets("Sheet1")
    Do
        If vStr = "False" Then Exit Do
        If vCol = 0 Then
            Set vFind = .Cells.Find(What:=vStr, LookIn:=xlFormulas, LookAt:=xlPart)
        Else
            Set vFind = .Columns(vCol).Find(What:=vStr, LookIn:=xlFormulas, LookAt:=xlPart)
        End If
        If Not vFind Is Nothing Then
            Set vFirst = vFind
            Do
                If tempRNG Is Nothing Then Set tempRNG = vFind _
                    Else Set tempRNG = Union(tempRNG, vFind)
                If vCol = 0 Then
                    Set vFind = .Cells.FindNext(vFind)
                Else
                    Set vFind = .Columns(vCol).FindNext(vFind)
                End If
            Loop Until vFind.Address = vFirst.Address
            Set vFind = Nothing
            Set vFirst = Nothing
            If findRNG Is Nothing Then
                Set findRNG = tempRNG
            Else
                If Not Intersect(findRNG, tempRNG) Is Nothing Then
                    Set findRNG = Intersect(findRNG, tempRNG)
                Else
                    MsgBox "Nothing matches"
                    Exit Sub
                End If
            End If
            Set tempRNG = Nothing
        End If
        vStr = Application.InputBox("Next String to search for:", "Search Data", Type:=2)
    Loop
End With

If findRNG Is Nothing Then
    MsgBox "Nothing found to copy."
    Exit Sub
End If
   
With Sheets("Sheet2")
    If MsgBox("Clear previous data?", vbYesNo, "Reset?") = vbYes Then
        .Range("A2:A" & Rows.Count).EntireRow.Clear
        findRNG.EntireRow.Copy .Range("A2")
    Else
        findRNG.EntireRow.Copy .Range("A" & .Rows.Count).End(xlUp).Offset(1)
    End If
End With

Set findRNG = Nothing
Sheets("Sheet2").Activate
End Sub




Nothing says "thanks" like a steak dinner!
PayPal - The safer, easier way to pay online!

Comments