Sub FilterAndSavePDF()
Dim cell As Range
Dim LastRow As Integer
Dim MyPath As String, MyFile As String
Dim DataRange As Range
MyPath = "D:\STECMATOURS\" '========>> Adapt the path
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set DataRange = ActiveSheet.Range("A1:H" & LastRow)
Application.ScreenUpdating = False
For Each cell In Range("A2:A" & LastRow)
DataRange.AutoFilter Field:=1, Criteria1:=cell
MyFile = cell.Value
DataRange.ExportAsFixedFormat Type:=xlTypePDF, FileName:=MyPath & MyFile _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
Next cell
ActiveSheet.ShowAllData
Application.ScreenUpdating = True
End Sub
Sub FilterAndSavePDF2()
Dim Ws As Worksheet
Dim cell As Range
Dim LastRow As Integer
Dim MyPath As String, MyFile As String
Dim DataRange As Range
Set Ws = ThisWorkbook.Sheets("Sheet1")
MyPath = "D:\STECMATOURS\" '========>> Adapt the path
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set DataRange = Ws.Range("A1:H" & LastRow)
Application.ScreenUpdating = False
For Each cell In Range("A2:A" & LastRow)
DataRange.AutoFilter Field:=1, Criteria1:=cell
MyFile = cell.Value
With Ws.PageSetup
.PrintArea = Ws.Range("B1", Range("H" & Rows.Count).End(xlUp)).Address
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
Ws.ExportAsFixedFormat Type:=xlTypePDF, FileName:=MyPath & MyFile _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
Next cell
With Ws
.ShowAllData
.PageSetup.PrintArea = ""
End With
Application.ScreenUpdating = True
End Sub
Glad to help & thanks for the feedback