我有一個 Excel 作業簿，其中用戶從作業表“報告生成器”的單元格 C4:C7 的下拉串列中輸入最多四個關鍵字，然后我的 VBA 代碼采用這些關鍵字，在另一個名為“資料”的作業表上進行過濾，復制過濾后的行并將它們作為報告粘貼到 Word 檔案中。該代碼最多同時適用于兩個關鍵字，但由于某些原因，當有三個或四個關鍵字時失敗，我不明白為什么。具體來說，當有三個或四個關鍵字時，過濾會回傳 0 行，因此沒有什么可復制的。如果我嘗試在 Excel 中手動執行此操作，則這不是問題，因此這不是資料問題。
下面是執行過濾的代碼部分。如您所見，if 回圈從最后一個開始依次檢查每個關鍵字是否為空，并將填充的關鍵字應用于過濾。回圈每次都成功完成，但由于某種原因，過濾命令在 3 或 4 個關鍵字的情況下回傳 0 行。你能幫我理解為什么會這樣嗎？謝謝！
'Filter data based on keywords selected
Sheets("Data").Select
'If user inputs 1 keyword
If IsEmpty(Sheets("Report generator").Range("C7")) = True And IsEmpty(Sheets("Report generator").Range("C6")) = True And IsEmpty(Sheets("Report generator").Range("C5")) = True Then
ActiveSheet.Range("$A$1:$F$1").AutoFilter Field:=5, Criteria1:= _
Array("*" & Sheets("Report generator").Range("C4").Value & "*"), _
Operator:=xlFilterValues
'If user inputs 2 keywords
ElseIf IsEmpty(Sheets("Report generator").Range("C7")) = True And IsEmpty(Sheets("Report generator").Range("C6")) = True Then
ActiveSheet.Range("$A$1:$F$1").AutoFilter Field:=5, Criteria1:= _
Array("*" & Sheets("Report generator").Range("C4").Value & "*", _
"*" & Sheets("Report generator").Range("C5").Value & "*"), _
Operator:=xlFilterValues
'If user inputs 3 keywords
ElseIf IsEmpty(Sheets("Report generator").Range("C7")) = True Then
ActiveSheet.Range("$A$1:$F$1").AutoFilter Field:=5, Criteria1:= _
Array("*" & Sheets("Report generator").Range("C4").Value & "*", _
"*" & Sheets("Report generator").Range("C5").Value & "*", _
"*" & Sheets("Report generator").Range("C6").Value & "*"), _
Operator:=xlFilterValues
'If user inputs 4 keywords
ElseIf IsEmpty(Sheets("Report generator").Range("C7")) = False And IsEmpty(Sheets("Report generator").Range("C6")) = False And IsEmpty(Sheets("Report generator").Range("C5")) = False And IsEmpty(Sheets("Report generator").Range("C4")) = False Then
ActiveSheet.Range("$A$1:$F$1").AutoFilter Field:=5, Criteria1:= _
Array("*" & Sheets("Report generator").Range("C4").Value & "*", _
"*" & Sheets("Report generator").Range("C5").Value & "*", _
"*" & Sheets("Report generator").Range("C6").Value & "*", _
"*" & Sheets("Report generator").Range("C7").Value & "*"), _
Operator:=xlFilterValues
End If
uj5u.com熱心網友回復：
復制過濾資料
- 主要問題是您不能在陣列中使用兩個以上包含通配符的元素
Criteria1。 - 以下內容會將過濾后的資料復制到第三個作業表 (
Report)。然后您可以將其匯出到Word.
Option Explicit
Sub CopyFilteredData()
Const lName As String = "Report Generator"
Const lrgAddress As String = "C4:C7"
Const sName As String = "Data"
Const sCols As String = "A:F"
Const sfField As Long = 5
Const dName As String = "Report"
Const dFirst As String = "A1"
Const doCopyHeaders As Boolean = True ' e.g. if dFirst = "A2" then 'False'
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Write the criterias to a dictionary.
Dim lws As Worksheet: Set lws = wb.Worksheets(lName)
Dim lrg As Range: Set lrg = lws.Range(lrgAddress)
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim lCell As Range
Dim lString As String
For Each lCell In lrg.Cells
lString = CStr(lCell.Value)
If Len(lString) > 0 Then
dict("*" & lString & "*") = Empty
End If
Next lCell
Dim dCount As Long: dCount = dict.Count
If dCount = 0 Then Exit Sub ' no criterias
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
If sws.AutoFilterMode Then
sws.AutoFilterMode = False
End If
' Source Table Range
Dim strg As Range: Set strg = sws.Range("A1").CurrentRegion.Columns(sCols)
' Source Data Range ('strg' without headers)
Dim sdrg As Range: Set sdrg = strg.Resize(strg.Rows.Count - 1).Offset(1)
Dim srg As Range
Select Case dCount
Case Is < 3 ' up to two criteria with wild characters
strg.AutoFilter sfField, dict.Keys, xlFilterValues
Set srg = sdrg.SpecialCells(xlCellTypeVisible)
sws.AutoFilterMode = False
Case Else ' more criteria with wild characters
Dim fpCount As Long: fpCount = Int(dCount / 2)
Dim UB As Long: UB = 1
Dim arr As Variant: ReDim arr(0 To 1)
Dim sfdrg As Range
Dim fp As Long
Dim n As Long
' For each filter pair...
For fp = 0 To fpCount
If fp = fpCount Then ' last loop only
If dCount Mod 2 = 1 Then ' count is odd: needs to loop once more
UB = 0
ReDim arr(0 To 0)
Else ' count is even: no need to loop anymore
UB = -1
End If
End If
If UB > -1 Then
' Write criteria pair to an array.
For n = 0 To UB
arr(n) = dict.Keys()(n fp * 2)
Next n
' Filter Source Data Range.
sdrg.AutoFilter sfField, arr, xlFilterValues
' Combine filtered range into Source Range.
On Error Resume Next
Set sfdrg = sdrg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
sws.AutoFilterMode = False
If Not sfdrg Is Nothing Then
If srg Is Nothing Then
Set srg = sfdrg
Else
Set srg = Union(srg, sfdrg)
End If
Set sfdrg = Nothing
End If
End If
Next fp
End Select
If srg Is Nothing Then Exit Sub
If doCopyHeaders Then
Set srg = Union(strg.Rows(1), srg)
End If
Debug.Print srg.Address(0, 0)
' Copy to the Destination worksheet.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
dws.Cells.Clear
Dim dfCell As Range: Set dfCell = dws.Range(dFirst)
srg.Copy dfCell
End Sub
轉載請註明出處，本文鏈接：https://www.uj5u.com/qukuanlian/342815.html
上一篇：如果使用vba的Excel電子表格中的單元格為空白，則將一列中文本的最后3個字符復制到另一列
下一篇：VBA|匯出為多頁PDF