I have an Excel workbook where a user inputs up to four keywords from a drop-down list in cells C4:C7 of sheet "Report generator", and my VBA code then takes these keywords, does a filtering on another sheet called "Data", copies the filtered rows and pastes them in a Word file as a report. The code works for up to two keywords at the same time, but for some reason fails when having three or four and I cannot understand why. Specifically, when having three or four keywords the filtering returns 0 rows so there is nothing to copy. This is not an issue if I try to do it manually in Excel so it's not a problem of the data.
Below is the part of the code that does the filtering. As you can see, the if loop checks sequentially whether each keyword is blank starting from the last one, and applies the filled-in keywords to the filtering. The loop finishes successfully every time, but for some reason the filtering command in cases of 3 or 4 keywords returns 0 rows. Could you please help me to understand why this happens? Thank you!
'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
CodePudding user response：
Copy Filtered Data
- The main issue is that you cannot use more than two elements containing wild characters in the
Criteria1array. - The following will copy the filtered data to a third worksheet (
Report). You could then export it toWord.
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