Autofilter Dynamic List Including Single Value

[jl1066]

I was looking for some guidance on auto filtering a dynamic set of values. I'm trying to auto filter a list of supplier names and after each name in the list copy the results into a blank Excel report and email the workbook to a user. Once the email is sent then the filter would move on to the next value and process the list until there are no more supplier names to filter, copy and email.

I have the logic working well if there are multiple values in the list of supplier names, but if there is only one name then the code will not filter for the only supplier name, but will return a null value and then continue with the copy and email function. If I remove the "-1" in the fourth row, the filter will go through the list of supplier names and will also filter for a null value at the end of the list (this will email a blank report to a user and is not desirable).

Column AB contains the list of values that I am filtering range A1:V1 on. Cell AB3 contains the title of the list.

This is my current code:

Dim aNames As Variant, Itm As Variant

With Range("AB3", Range("AB" & Rows.Count).End(xlUp))
.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
aNames = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlVisible).Value
Range("A1:V1").AutoFilter
For Each Itm In aNames
.AutoFilter Field:=3, Criteria1:=Itm

Range("A1").CurrentRegion.Select
Selection.Copy
Workbooks.Add
Set Workbook = ActiveWorkbook
Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
Range("A1").PasteSpecial Paste:=xlPasteFormats
Range("A1").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Application.DisplayAlerts = False
Range("X1").Value = Format(Now, "yyyy")

Dim Path1 As String
Dim Path2 As String

Path1 = Range("C2")
Path2 = Range("X1")

ActiveWorkbook.SaveAs file location
Emlreport = file location

Dim Email As Outlook.Application
Set Email = New Outlook.Application
Dim Sr As String
Dim newmail As Outlook.MailItem
Dim Email_Send_To As String
Set newmail = Email.CreateItem(olMailItem)
Email_Send_To = Workbooks("Supplier Status Report Macro.xlsm").Sheets("Menu").Range("D3").Value
newmail.To = Email_Send_To
newmail.Subject = Path1 & " Open Status Report"
Sr = Emlreport
newmail.attachments.Add Sr
newmail.send

Workbooks("Supplier Status Report Macro.xlsm").Activate

Next Itm
.AutoFilter
End With

Any help would be much appreciated.

 

[mart37]

Maybe you can use this:

Sub filter()
    Dim aNames() As Variant, Itm As Variant, i As Long
    Dim rNames As Range, cll As Range
    If Range("AB3", Range("AB" & Rows.Count).End(xlUp)).Count = 1 Then Exit Sub
    With Range("AB3", Range("AB" & Rows.Count).End(xlUp))
        .AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        Set rNames = .SpecialCells(xlVisible)
    End With
    i = 0
    ReDim Preserve aNames(0 To rNames.Count - 1)
    For Each cll In rNames
        aNames(i) = cll.Value
        i = i + 1
    Next
    With Range("A1:V1")
        For i = 1 To rNames.Count - 1
            .AutoFilter Field:=3, Criteria1:=aNames(i)
        Next
        .AutoFilter
    End With
End Sub

 

[jl1066]

That worked perfectly! Thanks for the help.