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