VBA code loop that will search and copy/paste based on list of criteria

Question

I have a sheet with data more then 30 000 rows and I want to copy all rows to a new excel file if column of a certain (for example "B") row contains certain values (list of these values will be in other sheet "Code"). So for example:

1. In sheet "Code" I have ten (could be even 30) different numbers (criteria) in column "A".
2. Start search to copy all rows (in new excel file) that contain any of these numbers from sheet "Code" in column "A".

Not very good at VBA yet but working on it:) Thanks for everyone for help!

Answer 1

Filter By Multiple Criteria and Export to Another Workbook

• Just to demonstrate why the question is not so well received. It's sort of 50 questions in one.
• Adjust the values in the constants section, and you should be good to go.
• "Sheet2" is actually your worksheet "Code". "Sheet1" is the first worksheet.

The Code

Option Explicit

Sub exportMultiToWorkbook()
    
    ' Error Handler
    
    ' Initialize error handling.
    Const procName As String = "exportMultiToWorkbook"
    On Error GoTo clearError ' Turn on error trapping.
    
    ' Constants
    
    ' Criteria
    Const critName As String = "Sheet2"
    Const critFirstCell As String = "A2"
    ' Source
    Const srcName As String = "Sheet1"
    Const srcFirstCell As String = "A1"
    Const srcCritColumn As Long = 2
    Dim wbs As Workbook
    Set wbs = ThisWorkbook ' The workbook containing this code.
    ' Target
    Const tgtFirstCell As String = "A1"
    Dim tgtPath As String
    ' The same path as Source Workbook ('wbs'). Change if necessary.
    tgtPath = wbs.Path & Application.PathSeparator & "Criteria"
    ' Other
    Dim Success As Boolean
    Dim AfterCop As Boolean
    
    ' Criteria
    
    ' Define Criteria Worksheet ('crit').
    Dim crit As Worksheet
    Set crit = wbs.Worksheets(critName)
    ' Define Criteria First Cell Range ('fcel').
    Dim fcel As Range
    Set fcel = crit.Range(critFirstCell)
    ' Define Criteria Processing Column Range ('pcr').
    Dim pcr As Range
    Set pcr = fcel.Resize(crit.Rows.Count - fcel.Row + 1)
    ' Define Criteria Last Non-Empty Cell Range ('lcel').
    Dim lcel As Range
    Set lcel = pcr.Find(What:="*", _
                       LookIn:=xlFormulas, _
                       SearchDirection:=xlPrevious)
    ' Validate Last Non-Empty Cell Range.
    If lcel Is Nothing Then
        GoTo ProcExit
    End If
    ' Define Criteria Column Range ('cr').
    Dim cr As Range
    Set cr = crit.Range(fcel, lcel)
    ' Write values from Criteria Column Range to 1D Criteria Array ('Criteria'),
    ' probably using Criteria 2D Array ('Crit2D').
    Dim Criteria As Variant
    Dim i As Long
    If cr.Rows.Count > 1 Then
    ' Criteria Column Range has multiple cells (rows).
        ' Write values from Criteria Range to Criteria 2D Array.
        Dim Crit2D As Variant
        Crit2D = cr.Value
        ' Write values from Criteria 2D Array to 1D Criteria Array.
        ReDim Criteria(1 To UBound(Crit2D, 1))
        For i = 1 To UBound(Crit2D)
            Criteria(i) = CStr(Crit2D(i, 1)) ' AutoFilter prefers strings.
        Next i
    Else
    ' Criteria Column Range has one cell (row) only.
        ' Write the only value from Criteria Column Range to Criteria Array.
        ReDim Criteria(1)
        Criteria(1) = CStr(cr.Value) ' AutoFilter prefers strings.
    End If
         
    ' Source
         
    ' Define Source Worksheet ('src').
    Dim src As Worksheet
    Set src = wbs.Worksheets(srcName)
    ' Define Source First Cell Range ('fcel').
    Set fcel = src.Range(srcFirstCell)
    ' Define Source Last Cell Range ('lcel').
    Set lcel = fcel.End(xlToRight).End(xlDown)
    ' Define Copy Range
    Dim cop As Range
    Set cop = src.Range(fcel, lcel)
    ' Turn off screen updating.
    Application.ScreenUpdating = False
    ' Turn off filter, if on.
    If src.FilterMode Then
        cop.AutoFilter
    End If
    ' Filter data. AutoFilter prefers the whole range.
    cop.AutoFilter Field:=srcCritColumn, _
                   Criteria1:=Criteria, _
                   Operator:=xlFilterValues
    ' Enable the use of 'SafeExit' instead of 'ProcExit' after possible error.
    AfterCop = True
    
    ' Target
    
    ' Add a new workbook.
    With Workbooks.Add
        ' Copy Copy Range to the first sheet of a new workbook.
        cop.Copy .Worksheets(1).Range(tgtFirstCell)
        ' I prefer to save this way; always a different file.
        tgtPath = tgtPath & " " & Format(Now, "YYYYMMDD_HHMMSS")
        .SaveAs Filename:=tgtPath, _
                FileFormat:=xlOpenXMLWorkbook ' i.e. ".xlsx"
         ' If you prefer the file to have the same name and for it to be
         ' overwritten without Excel complaining, then rather use the following:
'        Application.DisplayAlerts = False
'        .SaveAs Filename:=tgtPath, _
'                FileFormat:=xlOpenXMLWorkbook ' i.e. ".xlsx"
'        Application.DisplayAlerts = True
        .Close
    End With
    Success = True
         
SafeExit:
    
    ' Source
    
    ' Turn off filter.
    cop.AutoFilter
    wbs.Saved = True
    
    ' Turn on screen updating.
    Application.ScreenUpdating = True
    
ProcExit:
   
   ' Inform user.
        
    If Success Then
        MsgBox Prompt:="Created file '" & tgtPath & "'.", _
               Buttons:=vbInformation, _
               Title:="Multiple Criteria Filter - Success"
    Else
        MsgBox Prompt:="Could not finish task.", _
               Buttons:=vbCritical, _
               Title:="Multiple Criteria Filter - Fail"
    End If

    Exit Sub

clearError:
    Debug.Print "'" & procName & "': " & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    On Error GoTo 0 ' Turn off error trapping.
    If Not AfterCop Then
        GoTo ProcExit
    Else
        GoTo SafeExit
    End If

End Sub

Answer 2

I understand you are new and don't want to discourage you from seeking help in the future. Please attempt to ask more specific questions in the future. For example, you could ask how to find out if the value of one cell matches the value of any cell in a range of cells. That said, I have the sense you didn't know where to start, so I'll give it a shot. VBasic 2008 already provided an excellent answer, and actually wrote code for you, which you should not expect. VBasic 2008's code is great but be a more than you need and also a bit much for a beginner to understand. In the code below, you really only need to modify the three "set" lines in the CopyFilteredDemo procedure.

Below is simple code that makes several simplifying assumptions. Based on your request, I assume this meets your needs. If not, add more specificity. Many of these limitations of the assumptions listed below are easily overcome, but I don't want to write code for the heck of it.

1. Either the source and destination workbooks are the same, or they are both open. (I only tested different sheets in the same workbook, but it should work across workbooks.)
2. The source and destination worksheets are not the same. An error is intentionally raised if they are the same.
3. The destination worksheet already exists. $) The desitnation worksheet will be completely cleared and overwritten. Change True to False in CopyFilteredDemo so as to pass, so as to pass False to CopyFiltered.
4. Search only the first column of the source range for a an exact match in the filter range. Since the whole row is copied, it doesn't matter what column you set as the first column in fromRange. Just pick the column you wish to compare to values in filterRange.
5. Where not filtered out, the entire worksheet row will be copied.
6. No duplicates in filter criteria. I have not tested this to see if it causes duplicates in the destination worksheet.
7. Not performance tested on thousands of rows. If you see issues, first set Application.ScreenUpdating = False. Turn it on again at the end. Be sure you have error handling to turn in back on in case of an error. Otherwise ScreenUpdatingwill remain off, which you'll find is highly undesirable. If this is beyond your current comfort level, don't disable ScreenUpdating.

As an outline, the main procedure is CopyFiltered, which copies data from one sheet to another. This procedure calls the IsInRange function, which returns true if argument valueToFind exactly matches a value in the range specified by argument RangeToSearch. So, when comparing the source range (fromRange) to the filter criteria (filterRange), the first column of fromRange is compared. fromRange does not determine which columns are copied, since you requested to copy entire rows. Rather fromRange has 2 purposes. First, it determine the rows from which to copy. Second, the first column of fromRange is compared to the filterRange for a match.

I placed a good amount of comments in the code, so I hope it is relatively easy to understand.

Option Explicit
' Option Explicit must be the first line of code in the module. 
' It forces you to declare every variable.  It may seem a nuisance
' to a beginner, but you will quickly learn its value.  It will 
' keep you from spelling the same variable two ways and failing 
' to understand why your code failed.  There are other benefits 
' that you'll pick up over time, such as conserving memory and
' forcing data typing.

Public Function IsInRange(ByVal valueToFind, ByVal RangeToSearch As Range)
    ' If any cell in RangeToSearch = valueToFind, return True
    ' Else return False.
    Dim x
   
    ' If valueToFind is not in RangeToSearch, expect
    ' error 91.  That's okay, we'll handle that error
    ' and return False.  If we get a differnt error,
    ' we'll raise it.
    On Error GoTo EH
    x = RangeToSearch.Find(valueToFind)
    On Error GoTo 0

    ' If we made it this far, we found it!
    IsInRange = True


Exit Function
EH:
    If Err.Number = 91 Then
        ' this error is expected if valueToFind is not in RangeToSearch
        IsInRange = False
        Err.Clear
    Else
        ' Unexpected error.
        Err.Raise Number:=Err.Number, Source:=Err.Source _
                  , Description:=Err.Description
    End If
End Function


Sub CopyFiltered(ByVal fromRange As Range, ByVal toRange As Range _
                 , ByVal filterRange As Range _
                 , Optional clearFirst As Boolean = True)

' Arguments:
'   fromRange: the full range from which to copy
'   toRange: the top left cell fromRange will be pasted to the
'              top left cell of toRange.  The size of toRange
'              is irrelevant.  Only the top left cell is used
'              for reference.
'   fitlerRange: a range containing values with which to filter.
'   clearFirst: if True, clear all content from range containing
'               toRange before pasting new values.

    Dim rng As Range, rowOffset As Integer
    Dim rowNum As Integer, colNum As Integer, i As Integer
    Dim errMsg As String, cell As Range
    
    Set toRange = toRange.Cells(1, 1)
    Set fromRange = fromRange.Columns(1)
    
    ' If fromRange and toRange are on the same worksheet,
    ' raise an exception.
    If fromRange.Worksheet.Name = toRange.Worksheet.Name Then
        errMsg = "fromRange and toRange cannot be on the same worksheet."
        Err.Raise 1000, "CopyFiltered", errMsg
        Exit Sub
    End If
    
    ' Clear all content from the destination worksheet.
    toRange.Worksheet.Cells.ClearContents

    '
    ' Loop through each row of fromRange
    rowOffset = -1
    For i = 1 To fromRange.Rows.Count
        Set cell = fromRange.Cells(i, 1)
        Debug.Print cell.Address
        ' If the the cell in the first column of fromRange
        ' exaclty equals any cell in filterRange, proceed.
        If IsInRange(cell.Value, filterRange) Then
            ' Add one to rowOffset, so we copy this row
            ' below the last pasted row of the sheet
            ' containing toRange
            rowOffset = rowOffset + 1
            cell.EntireRow.Copy toRange.Offset(rowOffset, 0).EntireRow
        End If
    Next i

End Sub



Sub CopyFilteredDemo()
    Dim fromRange As Range, toRange As Range, filterRange As Range
    
    ' Set our to, from and filter ranges
    Set fromRange = Sheets("Sheet1").Range("c10:c40")
    Set toRange = Sheets("Sheet2").Range("A2")
    Set filterRange = Sheets("Sheet1").Range("B2:B6")
    
    ' Run our filtered copy procedure.
    CopyFiltered fromRange, toRange, filterRange, True
End Sub