将根据条件列表搜索和复制/粘贴的 VBA 代码循环

Question

我有一张包含超过 30 000 行数据的工作表，如果某个（例如“B”）行的列包含某些值（这些值的列表将在其他表“代码”）。 比如：

1. 在“代码”表中，“A”列中有十个（甚至可能是 30 个）不同的数字（标准）。
2. 开始搜索以从“A”列的“代码”表中复制所有包含这些数字的行（在新的 Excel 文件中）。

还不是很擅长 VBA，但正在努力：) 感谢大家的帮助！

Answer 1

我了解您是新手，不想阻止您以后寻求帮助。请尝试在未来提出更具体的问题。例如，您可能会问如何确定一个单元格的值是否与一系列单元格中的任何单元格的值匹配。也就是说，我感觉你不知道从哪里开始，所以我会试一试。 VBasic 2008 已经提供了一个很好的答案，并且实际上为您编写了代码，这是您不应该期望的。 VBasic 2008 的代码很棒，但比你需要的多，对于初学者来说也有点理解。在下面的代码中，您实际上只需要修改 CopyFilteredDemo 过程中的三个“设置”行。

下面是一些简单的代码，它做了几个简化的假设。根据您的要求，我认为这可以满足您的需求。如果没有，请添加更多特异性。下面列出的假设的许多限制很容易克服，但我不想为此编写代码。

1. 源工作簿和目标工作簿是相同的，或者它们都是打开的。 （我只在同一个工作簿中测试了不同的工作表，但它应该可以跨工作簿工作。）
2. 源工作表和目标工作表不同。如果它们相同，则会故意引发错误。
3. 目标工作表已经存在。 $) 目标工作表将被完全清除和覆盖。将 CopyFilteredDemo 中的 True 改为 False 以便通过，从而将 False 传递给 CopyFiltered。
4. 仅在源范围的第一列中搜索筛选范围中的完全匹配项。由于复制了整行，因此您将哪一列设置为 fromRange 中的第一列并不重要。只需选择您希望与 filterRange 中的值进行比较的列。
5. 如果没有过滤掉，整个工作表行将被复制。
6. 筛选条件中没有重复项。我没有对此进行测试，看看它是否会导致目标工作表中出现重复。
7. 未对数千行进行性能测试。如果您发现问题，请首先设置 Application.ScreenUpdating = False。最后再次打开它。确保您有错误处理以在出现错误时重新打开。否则 ScreenUpdating 将保持关闭状态，您会发现这是非常不受欢迎的。如果这超出了您当前的舒适度，请不要禁用 ScreenUpdating。

概括地说，主要过程是 CopyFiltered，它将数据从一张表复制到另一张表。此过程调用 IsInRange 函数，如果参数 valueToFind 与参数 RangeToSearch 指定的范围内的值完全匹配，则该函数返回 true。因此，在将源范围 (fromRange) 与过滤条件 (filterRange) 进行比较时，会比较 fromRange 的第一列。 fromRange 无法确定要复制哪些列，因为您请求复制整行。而 fromRange 有两个目的。首先，它确定要从中复制的行。其次，将 fromRange 的第一列与 filterRange 进行比较以进行匹配。

我在代码中放置了大量的cmets，所以我希望它相对容易理解。

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

Answer 2

按多个条件过滤并导出到另一个工作簿

• 只是为了说明为什么这个问题没有那么受欢迎。这是一个 50 个问题。
• 调整常量部分中的值，一切顺利。
• “Sheet2”实际上是您的工作表“代码”。 “Sheet1”是第一个工作表。

守则

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