VBA 將根據條件列表搜索和復制/粘貼的代碼循環

Question

我有一張數據超過 30 000 行的工作表，如果某個（例如“B”）行的列包含某些值（這些值的列表將在其他工作表中），我想將所有行復制到新的 excel 文件中代碼”）。 例如：

1. 在“代碼”表中，“A”列中有十個（甚至可能是 30 個）不同的數字（標准）。
2. 開始搜索以復制所有行（在新的 excel 文件中），這些行包含工作表“代碼”中“A”列中的任何這些數字。

不太擅長 VBA，但正在努力:) 感謝大家的幫助！

Answer 1

按多個條件過濾並導出到另一個工作簿

• 只是為了證明為什么這個問題不那么受歡迎。 這是一個 50 個問題。
• 調整常量部分的值，你應該可以達到 go。
• “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

Answer 2

我了解您是新來的，不想阻止您將來尋求幫助。 請嘗試在未來提出更具體的問題。 例如，您可能會問如何確定一個單元格的值是否與一系列單元格中任何單元格的值匹配。 也就是說，我覺得你不知道從哪里開始，所以我試一試。 VBasic 2008 已經提供了一個很好的答案，並且實際上為您編寫了代碼，這是您不應該期望的。 VBasic 2008 的代碼很棒，但比您需要的要多，對於初學者來說也有點難以理解。 在下面的代碼中，您實際上只需要修改 CopyFilteredDemo 過程中的三個“設置”行。

下面是簡單的代碼，它做了幾個簡化的假設。 根據您的要求，我認為這可以滿足您的需求。 如果沒有，請添加更多特異性。 下面列出的假設的許多限制很容易克服，但我不想為此編寫代碼。

1. 源工作簿和目標工作簿相同，或者都已打開。 （我只在同一個工作簿中測試了不同的工作表，但它應該跨工作簿工作。）
2. 源工作表和目標工作表不同。 如果它們相同，則會故意引發錯誤。
3. 目標工作表已存在。 $) 目標工作表將被完全清除和覆蓋。 在CopyFilteredDemo中將True改為False以便通過，以便將False傳遞給CopyFiltered。
4. 僅在源范圍的第一列中搜索篩選范圍中的完全匹配項。 由於復制了整行，因此將哪一列設置為 fromRange 中的第一列並不重要。 只需選擇您希望與 filterRange 中的值進行比較的列。
5. 在沒有過濾掉的地方，整個工作表行將被復制。
6. 過濾條件中沒有重復項。 我沒有對此進行測試，看它是否會導致目標工作表中出現重復項。
7. 未在數千行上進行性能測試。 如果您發現問題，請先設置 Application.ScreenUpdating = False。 最后再打開它。 確保您有錯誤處理以在發生錯誤時重新打開。 否則屏幕更新將保持關閉狀態，您會發現這是非常不受歡迎的。 如果這超出了您當前的舒適度，請不要禁用 ScreenUpdating。

概括地說，主要過程是 CopyFiltered，它將數據從一張紙復制到另一張紙。 此過程調用 IsInRange function，如果參數 valueToFind 與參數 RangeToSearch 指定的范圍內的值完全匹配，則返回 true。 因此，在比較源范圍 (fromRange) 和過濾條件 (filterRange) 時，會比較 fromRange 的第一列。 fromRange 不確定要復制哪些列，因為您請求復制整行。 而 fromRange 有兩個目的。 首先，它確定要復制的行。 其次，將 fromRange 的第一列與 filterRange 進行比較以進行匹配。

我在代碼中放置了大量的注釋，所以我希望它相對容易理解。

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