Loop through filtered criteria only once

Question

The goal of this script is to loop through each criteria filtered in Column C, starting from C8 where my header is located. The information below will be a list of names of customer which will vary in quantity.

So far, the script filters each value. However, it does this literally. When I run the code step by step I need to press F8 three times to finish the loop of Client 1, and two times for Client 2.

How can I best improve the filtering? Ideally, the script should filter Client 1 then copy the range A8:M8 with dropdown and create an email (I have this other script ready); then it should filter client 2 and do the same.

Is there a way the filter can go through each criteria just once and then jump into the other?

Thanks in advance for the clarifications.

Sub Filtering()

Dim Clients As Variant, Name As Variant

Set ws = Excel.ThisWorkbook.Worksheets("Hermes")

If Sheets("Hermes").AutoFilterMode = True Then

'Do Nothing

Else

ws.Range("A8:M8").AutoFilter Field:=3 'Filtering the column Ship To Names with the clients' names

 With Range("C8", Range("C" & Rows.Count).End(xlUp))
    Clients = .SpecialCells(xlVisible).Value
    For Each Name In Clients
      .AutoFilter Field:=3, Criteria1:=Name
      
      'Place script to create email for this specific client.
      
    Next Name
    .AutoFilter
  End With

End If

End Sub

---

Wizhi below provided the solution. I replaced my filtering script with his/hers and added the script that generates the emails, resulting in this one I am pasting below. NOTE: Amends need to be done as the script is not taking the correct email for each customer nor attaching all of the PDFs*

'Option Explicit

Sub Filtering()

Dim ws As Worksheet
Dim lrow_Critera_Data_Range As Long, lcol_Critera_Data_Range As Long


Set ws = Excel.ThisWorkbook.Worksheets("Hermes")


If Sheets("Hermes").AutoFilterMode Then 'If autofilter exists, then remove filter
    Sheets("Hermes").AutoFilterMode = False
End If


'##### Get all the uniqe filter values #####
ws.AutoFilterMode = False 'Remove filter

Dim Critera_Data_Range() 'Range to filter
Dim Unique_Criteria_Data As Object 'Range to filter but with only unique values
Dim Filter_Row As Long

Set Unique_Criteria_Data = CreateObject("Scripting.Dictionary") 'Create dictionary to store unique values

lrow_Critera_Data_Range = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row 'Last row in filter range
lcol_Critera_Data_Range = ws.Cells(8, ws.Columns.Count).End(xlToLeft).Column 'Last column in filter range

Critera_Data_Range = Application.Transpose(ws.Range(ws.Cells(8, "C"), ws.Cells(lrow_Critera_Data_Range, "C"))) 'Get all the Client names

For Filter_Row = 2 To UBound(Critera_Data_Range, 1) 'Start from row 2 (to skip header) and add unique values to the dictionary
    Unique_Criteria_Data(Critera_Data_Range(Filter_Row)) = 1 'Add value to dictionary
Next


'##### Loop through all the unqie Filter values and copy #####
Dim Filter_Value As Variant
Dim MyRangeFilter As Range


Set MyRangeFilter = ws.Range(ws.Cells(8, "A"), ws.Cells(lrow_Critera_Data_Range, lcol_Critera_Data_Range)) 'Set filter range

For Each Filter_Value In Unique_Criteria_Data.Keys 'Filter through all the unique names in dictionary "Unique_Criteria_Data"
    'Debug.Print "Current Criteria: " & Filter_Value 'Print current unique Destination Pincode name

    With MyRangeFilter
        .AutoFilter Field:=3, Criteria1:=Filter_Value, Operator:=xlFilterValues 'Filtering the 3rd column and filter the current filter value
    End With
    
    ws.Range(ws.Cells(8, "A"), ws.Range(ws.Cells(8, "A"), ws.Cells(ws.Cells(Rows.Count, "C").End(xlUp).Row, ws.Cells(8, ws.Columns.Count).End(xlToLeft).Column))).SpecialCells(xlCellTypeVisible).Copy 'copy only visible data from the filtering
    
    Application.CutCopyMode = False 'Clear copy selection
    
    'Paste script and then
    'Place script to create email for this specific client.
    
    ' Make all the Dims
Dim OutApp As Object
Dim OutMail As Object
Dim SigString As String
Dim Signature As String
Dim rng As Range
Dim lRow As Long, lCol As Long
Dim StrBody As String

'Select the signature to use
    SigString = Environ("appdata") & _
                "\Microsoft\Signatures\" & Cells(2, 7).Text & ".htm"

    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If

    On Error Resume Next
    
' Set the abbreviations
Set ws = Excel.ThisWorkbook.Worksheets("Hermes")
StrBody = Sheets("Hermes").Range("C5").Value
filePath = ws.Cells(5, 1)
Subject = ws.Cells(2, 5)

i = 9

'Select the appropriate range to copy and paste into the body of the email
    Set rng = Nothing
    On Error Resume Next
    Set rng = Sheets("Hermes").Range("A8:M" & Range("A8:M8").End(xlDown).Row).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "The selection is not valid." & _
               vbNewLine & "Please correct and try again.", vbOKOnly
        Exit Sub
    End If

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

'Create email
With OutMail
            .Subject = Cells(i, 19).Text & "- " & Subject & Date
            .To = Cells(i, 15).Value
            .CC = Cells(i, 16).Value
            .Bcc = Cells(i, 17).Value
            .Importance = 2
            .Attachments.Add filePath & "\" & Cells(i, 4) & ".pdf"
            .HTMLBody = StrBody & RangetoHTML(rng) & "<br>" & Signature
            .SentOnBehalfOfName = Sheets("Hermes").Cells(2, 3).Text
            .Display
End With

    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
    
Next Filter_Value


On Error Resume Next
    ws.ShowAllData  'Reset filter
On Error GoTo 0

End Sub

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006

    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function

Answer 1

So I made some adjustments to your code since I didn't understood the logic. I.e. The check for autofilter is changed. I also defined the last row / last column to make it a bit more easy to follow the code.

So the logic for the filter is to take all the values in the range you want to filter and then get all the unique values from that range. Then you filter for each unique value in a for each loop (i.e. use that unique value as filter criteria).

I just made a .SpecialCells(xlCellTypeVisible).Copy with the header and the data since I don't know what you want to do after each filtering :).

Think this should be a quite easy start and might need to adjust part of the code to fit into your project (i.e. active filter or not etc..).

Full Code:

Option Explicit

Sub Filtering()

Dim ws As Worksheet
Dim lrow_Critera_Data_Range As Long, lcol_Critera_Data_Range As Long


Set ws = Excel.ThisWorkbook.Worksheets("Hermes")


If Sheets("Hermes").AutoFilterMode Then 'If autofilter exists, then remove filter
    Sheets("Hermes").AutoFilterMode = False
End If


'##### Get all the uniqe filter values #####
ws.AutoFilterMode = False 'Remove filter

Dim Critera_Data_Range() 'Range to filter
Dim Unique_Criteria_Data As Object 'Range to filter but with only unique values
Dim Filter_Row As Long

Set Unique_Criteria_Data = CreateObject("Scripting.Dictionary") 'Create dictionary to store unique values

lrow_Critera_Data_Range = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row 'Last row in filter range
lcol_Critera_Data_Range = ws.Cells(8, ws.Columns.Count).End(xlToLeft).Column 'Last column in filter range

Critera_Data_Range = Application.Transpose(ws.Range(ws.Cells(8, "C"), ws.Cells(lrow_Critera_Data_Range, "C"))) 'Get all the Client names

For Filter_Row = 2 To UBound(Critera_Data_Range, 1) 'Start from row 2 (to skip header) and add unique values to the dictionary
    Unique_Criteria_Data(Critera_Data_Range(Filter_Row)) = 1 'Add value to dictionary
Next


'##### Loop through all the unqie Filter values and copy #####
Dim Filter_Value As Variant
Dim MyRangeFilter As Range


Set MyRangeFilter = ws.Range(ws.Cells(8, "A"), ws.Cells(lrow_Critera_Data_Range, lcol_Critera_Data_Range)) 'Set filter range

For Each Filter_Value In Unique_Criteria_Data.Keys 'Filter through all the unique names in dictionary "Unique_Criteria_Data"
    'Debug.Print "Current Criteria: " & Filter_Value 'Print current unique Destination Pincode name

    With MyRangeFilter
        .AutoFilter Field:=3, Criteria1:=Filter_Value, Operator:=xlFilterValues 'Filtering the 3rd column and filter the current filter value
    End With
    
    ws.Range(ws.Cells(8, "A"), ws.Range(ws.Cells(8, "A"), ws.Cells(ws.Cells(Rows.Count, "C").End(xlUp).Row, ws.Cells(8, ws.Columns.Count).End(xlToLeft).Column))).SpecialCells(xlCellTypeVisible).Copy 'copy only visible data from the filtering
    
    Application.CutCopyMode = False 'Clear copy selection
    
    'Paste script and then
    'Place script to create email for this specific client.
    
    
Next Filter_Value


On Error Resume Next
    ws.ShowAllData  'Reset filter
On Error GoTo 0

End Sub