****************Advance Filtering and save file as PDF**************************

Dim wkb As ThisWorkbook
Dim h As Variant
Dim RowCount As Integer
Dim Rng As Range
Dim Fso As FileSystemObject
Dim Fpath As String
Dim Fldr As String
Dim Workbk_name As String
Dim LoopCount As Integer
Dim filename As String

Sub Testing()

On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False

MsgBox "Select Destination Path", vbOKOnly + vbInformation
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
Fpath = .SelectedItems(1) & "\"
End With

filename = ThisWorkbook.Name
Fldr = Fpath & Format(Now(), "DD-MMM-YYYY")
RowCount = Cells(Rows.Count, 6).End(xlUp).Row

h = Cells(1, 6).Resize(RowCount, 1)
Cells(1, 9).Resize(RowCount, 1).Value = h

LoopCount = Cells(Rows.Count, 9).End(xlUp).Row

Set Fso = New FileSystemObject
If Not Fso.FolderExists(Fldr) Then
Fso.CreateFolder Fpath & Format(Now(), "DD-MMM-YYYY")
Else
MsgBox "Folder already exists!!!!!", vbExclamation, "Folder Exists"
Sheet1.Range("i:i").Clear
Exit Sub
End If

Range("i1:i" & RowCount).RemoveDuplicates Columns:=1, Header:=xlYes

For i = 2 To LoopCount

Set Rng = Range("a1").CurrentRegion

Rng.AutoFilter field:=6, Criteria1:=Cells(i, 9), VisibleDropDown:=False
Range("a1").CurrentRegion.Select
Selection.Columns.AutoFit

Workbk_name = Application.Workbooks(filename).Sheets(1).Cells(i, 9)

Selection.ExportAsFixedFormat Type:=xlTypePDF, filename:=Fldr & "\" & Workbk_name & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
Range("A1").Select
Selection.AutoFilter

Next i

ActiveWorkbook.Sheets(1).Range("i1:i" & LoopCount).Select
Selection.ClearContents
Range("A1").Select
MsgBox "Done....", vbInformation

End Sub