Below you can find my code that is working for a certain area. But I want to add a new element in the code but I can't find it how I can do it. The first area is A1:E42, but now I have one worksheet where I have 3 area. A1:E42, H1:K42 and O1:R42). How do I need to rewrite my code that the first area comes on the first pdf page, the second area on the second page et cetera.
Sub SavePDF()
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet
With ws.PageSetup
.Orientation = xlLandscape
.Zoom = False
.FitToPagesTall = 1
.FitToPagesWide = 1
.PrintArea = "A1:E42"
End With
Set ws = Nothing
Sheets("Offerte_M").ExportAsFixedFormat x1TypePDF, Filename:= _
"C:\Intel\" & ActiveSheet.Range("F21").Value & ".pdf" _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
MsgBox "Offerte has been saved as PDF. Press send now."
I thought maybe this was the correct way, but that doesn't work also.
Sub CommandButton1_Click()
Application.ScreenUpdating = False
Offerte_M.PageSetup.PrintArea = "A1:E42"
Offerte_M.PageSetup.PrintArea = "H1:K42"
Offerte_M.PageSetup.PrintArea = "O1:R42"
Worksheets(Array("Offerte_M")).Select.ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:="C:\Intel\" & ActiveSheet.Range("F21").Value & ".pdf", _
OpenAfterPublish:=True
Offerte_M.PageSetup.PrintArea = ""
Offerte_M.PageSetup.PrintArea = ""
Offerte_M.PageSetup.PrintArea = ""
Offerte_M.Select
Application.ScreenUpdating = True
End Sub
I have a problem with sheet hiding. I want to print the document, which includes the sheets with a similar name.
I did something like this:
Sub DPPtoPDF()
Dim ws As Worksheet
Sheets("Readme").Visible = False
Sheets("Asbuilt Photos 1").Visible = False
Sheets("Asbuilt Photos 2").Visible = False
Sheets("Splicing Photos").Visible = False
Sheets("Sign Off Sheet").Visible = False
For Each ws In ThisWorkbook.Worksheets
If ws.Name Like "OTDR*" Then
ws.Visible = False
End If
Next was
ThisWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ThisWorkbook.Path & "\" & ThisWorkbook.Name, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=True
Sheets("Readme").Visible = True
Sheets("Asbuilt Photos 1").Visible = True
Sheets("Asbuilt Photos 2").Visible = True
Sheets("Splicing Photos").Visible = True
Sheets("Sign Off Sheet").Visible = True
For Each ws In ThisWorkbook.Worksheets
If ws.Name Like "OTDR*" Then
ws.Visible = True
End If
Next was
Sheets("Frontsheet").Select
End Sub
following the solutions:
https://learn.microsoft.com/en-us/office/vba/api/excel.worksheet.visible
Unhide sheets names using VBA whose name contain specific word
https://excelchamps.com/vba/hide-sheet/
it returns over 2000 pages in my PDF document
What have I done wrong in the code?
I have about 30 sheets at most. How can I exclude (hide) the following sheets from printing it as the PDF?
I would suggest to do it with the print function. Here is my code:
Sub DPPtoPDF()
Dim ws As Worksheet
Sheets("Readme").Visible = False
Sheets("Asbuilt Photos 1").Visible = False
Sheets("Asbuilt Photos 2").Visible = False
Sheets("Splicing Photos").Visible = False
Sheets("Sign Off Sheet").Visible = False
For Each ws In ThisWorkbook.Worksheets
If ws.Name Like "OTDR*" Then
ws.Visible = False
End If
Next ws
Dim arr As Variant
Dim i As Integer
Dim counter As Integer
ReDim arr(counter)
'Add all visible sheets to an array (arr)
For i = 1 To Worksheets.Count
If Worksheets(i).Visible = True Then
ReDim Preserve arr(counter)
arr(counter) = Worksheets(i).Name
counter = counter + 1
End If
Next
'select all sheets the array contains
Worksheets(arr).Select
'set the path
printpath = ThisWorkbook.Path & "\" & ThisWorkbook.Name
'print the selection
ThisWorkbook.Windows(1).SelectedSheets.PrintOut PrintToFile:=True, PrToFileName:=printpath, ActivePrinter:="Microsoft Print to PDF", IgnorePrintAreas:=True
Sheets("Readme").Visible = True
Sheets("Asbuilt Photos 1").Visible = True
Sheets("Asbuilt Photos 2").Visible = True
Sheets("Splicing Photos").Visible = True
Sheets("Sign Off Sheet").Visible = True
For Each ws In ThisWorkbook.Worksheets
If ws.Name Like "OTDR*" Then
ws.Visible = True
End If
Next was
Sheets("Frontsheet").Select
End Sub
You just need to select multiple sheets and make only the selected sheets into a pdf file.
Sub DPPtoPDF()
Dim ws As Worksheet
Dim vName() As Variant
Dim n As Integer
ReDim vName(1 To 1000)
For Each ws In ThisWorkbook.Worksheets
If ws.Name Like "OTDR*" Or ws.Name = "Readme" Or ws.Name = "Asbuilt Photos 1" _
Or ws.Name = "Asbuilt Photos 2" Or ws.Name = "Splicing Photos" _
Or ws.Name = "Sign Off Sheet" Then
Else
n = n + 1
vName(n) = ws.Name
End If
Next ws
ReDim Preserve vName(1 To n)
Sheets(vName).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ThisWorkbook.Path & "\" & "test.pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=True
End Sub
Print Specified Worksheets
Option Explicit
Sub DPPtoPDF()
Const SheetNamesList As String = "Readme,Asbuilt Photos 1," _
& "Asbuilt Photos 2,Splicing Photos,Sign Off Sheet"
Const crit As String = "OTDR*"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim SheetNames() As String: SheetNames = Split(SheetNamesList, ",")
Dim sh As Object
Dim snms() As String
Dim shName As String
Dim n As Long
For Each sh In wb.Sheets
shName = sh.Name
If Not UCase(shName) Like crit Then
If IsError(Application.Match(shName, SheetNames, 0)) Then
ReDim Preserve snms(n)
snms(n) = shName
n = n + 1
End If
End If
Next sh
' Copy to new workbook
wb.Worksheets(snms).Copy
With ActiveWorkbook
.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=wb.Path & "\" & wb.Name, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
.Close False
End With
wb.Sheets("Frontsheet").Select
End Sub
I'm getting a "Compile Error: Syntax Error" when running the code below using Excel 2019. It works with the older version Excel, but not on 2019. How can I fix this and what's causing it?
the error line
ReportSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ThisWorkbook.Path & "\" & Cell, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=True, OpenAfterPublish:=False
The entire code
Option Explicit
Private Sub CommandButton1_Click()
Dim MyFolder As String, MyFile As String
Dim StartTime As Double
Dim MinutesElapsed As String
Dim Filename As String
Dim Cell As String
Dim Counter As Long
If ThisWorkbook.Sheets("Sheet1").Range("C7").Value = vbNullString Then
MsgBox "Enter Tab Name"
Exit Sub
End If
StartTime = Timer
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Select a Folder"
If .Show = True Then
MyFolder = .SelectedItems(1)
End If
If .SelectedItems.Count = 0 Then Exit Sub
Err.Clear
End With
'Turns settings off
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
MyFile = Dir(MyFolder & "\", vbReadOnly)
Do While MyFile <> ""
DoEvents
On Error GoTo 0
Workbooks.Open Filename:=MyFolder & "\" & MyFile, UpdateLinks:=False
Dim ReportSheet As Worksheet
Dim MySheet As String
Dim allColumns As Range
MySheet = ThisWorkbook.Sheets("Sheet1").Range("C7").Value
Set ReportSheet = Sheets(MySheet)
Set allColumns = ReportSheet.Columns("N:S")
allColumns.Hidden = True
With ReportSheet.PageSetup
.Zoom = False
.FitToPagesWide = 1 '.FitToPagesTall = 1
End With
Filename = ActiveWorkbook.Name
Cell = Replace(Filename, ".xlsx", ".PDF")
ReportSheet.Select
ReportSheet.PageSetup.Orientation = xlLandscape
ReportSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ThisWorkbook.Path & "\" & Cell, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=True, OpenAfterPublish:=False
Counter = Counter + 1
0
Workbooks(MyFile).Close SaveChanges:=False
MyFile = Dir
Loop
'turns settings back on that you turned off before looping folders
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.Calculation = xlCalculationManual
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "Successfully Converted " & Counter & " Files in " & MinutesElapsed & " minutes", vbInformation
End Sub
Leaving a blank line when you are using the line continuation _ character is not allowed in any Excel version (AFAIK)
The code giving you trouble should be:
ReportSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\" & Cell, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=True, OpenAfterPublish:=False
Try indenting your code properly and remove the extra lines.
Code:
Option Explicit
Private Sub CommandButton1_Click()
Dim MyFolder As String, MyFile As String
Dim StartTime As Double
Dim MinutesElapsed As String
Dim Filename As String
Dim Cell As String
Dim Counter As Long
If ThisWorkbook.Sheets("Sheet1").Range("C7").Value = vbNullString Then
MsgBox "Enter Tab Name"
Exit Sub
End If
StartTime = Timer
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Select a Folder"
If .Show = True Then
MyFolder = .SelectedItems(1)
End If
If .SelectedItems.Count = 0 Then Exit Sub
Err.Clear
End With
'Turns settings off
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
MyFile = Dir(MyFolder & "\", vbReadOnly)
Do While MyFile <> ""
DoEvents
On Error GoTo 0
Workbooks.Open Filename:=MyFolder & "\" & MyFile, UpdateLinks:=False
Dim ReportSheet As Worksheet
Dim MySheet As String
Dim allColumns As Range
MySheet = ThisWorkbook.Sheets("Sheet1").Range("C7").Value
Set ReportSheet = Sheets(MySheet)
Set allColumns = ReportSheet.Columns("N:S")
allColumns.Hidden = True
With ReportSheet.PageSetup
.Zoom = False
.FitToPagesWide = 1 '.FitToPagesTall = 1
End With
Filename = ActiveWorkbook.Name
Cell = Replace(Filename, ".xlsx", ".PDF")
ReportSheet.Select
ReportSheet.PageSetup.Orientation = xlLandscape
ReportSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\" & Cell, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=True, OpenAfterPublish:=False
Counter = Counter + 1
Workbooks(MyFile).Close SaveChanges:=False
MyFile = Dir
Loop
'turns settings back on that you turned off before looping folders
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.Calculation = xlCalculationManual
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "Successfully Converted " & Counter & " Files in " & MinutesElapsed & " minutes", vbInformation
End Sub
Side note: Didn't review other parts of your code
I have large spreadsheet that I'm looping through and printing each page to a pdf report.
I'm trying to print them A3 Landscape, however the actual export size is far larger than an A3 page.
Any suggestions I what I'm doing wrong?
Here is my current code:
Sub printChartsA3()
Application.ScreenUpdating = False
Dim sPrintArea As String
Dim wks As Worksheet
Const path As String = "E:\A3 Charts\"
sPrintArea = "A1:BM69"
For Each wks In Worksheets
Application.PrintCommunication = False
wks.PageSetup.PaperSize = xlPaperA3
wks.PageSetup.Orientation = xlLandscape
wks.PageSetup.LeftMargin = Application.InchesToPoints(0.25)
wks.PageSetup.RightMargin = Application.InchesToPoints(0.25)
wks.PageSetup.PrintArea = sPrintArea
wks.PageSetup.Zoom = False
wks.PageSetup.FitToPagesWide = 1
'wks.PageSetup.FitToPagesTall = 1 'not sure if this one is needed?
Application.PrintCommunication = True
wks.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=path & wks.Name & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Next
Set wks = Nothing
Application.ScreenUpdating = True
End Sub
I have a workbook already with a macro that does several things based on a cell value:
When i change a cell value (its a store name) the code will filter several sheets with, just to show the store of that specific cell, then hides several sheets.
Just showing 2 specific sheets.
And in the end of the code i save a new workbook with the name of that store.
My question is:
Is it possible to change my code (shown below), so i dont have to write manually the name of the store, ie, i want that the macro sees a list of stores, then change the cell with each store, do all the tasks i want, and then writes a new workbook with that store name, and so on, until the end of the list store?
Thank you so much
(PS: im new in vba, so my code probably is a little rough around the edges)
Sub Nova_loja()
Dim sht As Worksheet
Dim Fname As String
Dim Cell As Range, cRange As Range
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
'copy past in values
With Range("K44:L66")
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
End With
Application.CutCopyMode = False
'filter and delete
Sheets("BD Geral").Select
ActiveSheet.ListObjects("Table2").Range.AutoFilter Field:=52, Criteria1:="<>" & Worksheets("Tabela - Média Mensal").Range("B2").value, Operator:=xlFilterValues
Application.DisplayAlerts = False
ActiveSheet.ListObjects("Table2").DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
ActiveSheet.ListObjects("Table2").AutoFilter.ShowAllData
'filter and delete
Sheets("BD BONUS_MALUS").Select
ActiveSheet.ListObjects("Table35").Range.AutoFilter Field:=3, Criteria1:="<>" & Worksheets("Tabela - Média Mensal").Range("B1").value, Operator:=xlFilterValues
Application.DisplayAlerts = False
ActiveSheet.ListObjects("Table35").DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
ActiveSheet.ListObjects("Table35").AutoFilter.ShowAllData
'filter and delete
Sheets("BD NPS").Select
ActiveSheet.ListObjects("Table3").Range.AutoFilter Field:=2, Criteria1:="<>" & Worksheets("Tabela - Média Mensal").Range("B1").value, Operator:=xlFilterValues
Application.DisplayAlerts = False
ActiveSheet.ListObjects("Table3").DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
ActiveSheet.ListObjects("Table3").AutoFilter.ShowAllData
Sheets("BD Dept").Select
ActiveSheet.ListObjects("Table4").Range.AutoFilter Field:=8, Criteria1:="<>" & Worksheets("Tabela - Média Mensal").Range("B1").value, Operator:=xlFilterValues
Application.DisplayAlerts = False
ActiveSheet.ListObjects("Table4").DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
ActiveSheet.ListObjects("Table4").AutoFilter.ShowAllData
'refresh pivots
ThisWorkbook.RefreshAll
'hide sheets
For Each sht In ThisWorkbook.Worksheets
If sht.Name <> "Dashboard" And sht.Name <> "Tabela - Média Mensal" Then
sht.Visible = xlSheetVeryHidden
End If
Next sht
'protect sheets
For Each sht In ActiveWorkbook.Sheets
sht.Protect Password:="fnacrh", AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True
Next
'leave active main worksheet
Sheets("Dashboard").Select
'save as with new name
Application.DisplayAlerts = False
Fname = ThisWorkbook.Path & "\" & "02.VIM_REPORT MENSAL - " & Worksheets("aux").Range("V2") & " - " & Worksheets("aux").Range("V3") & ".xlsx"
ActiveWorkbook.SaveAs Filename:=Fname, FileFormat:=xlWorkbookDefault
Application.DisplayAlerts = True
Application.DisplayStatusBar = True
Application.ScreenUpdating = True
End Sub
Thank you so much
The next code would do what I understood you need.
Copy the next code in a module of another workbook, different from the one to be processed, and run AutomaticallySelectStore procedure. An InputBox will appear asking to select the number from the right side of the workbook name to be processed.
Sub AutomaticallySelectStore()
Dim w As Workbook, Wb As Workbook, sh As Worksheet, store As Variant, Arr As Variant, Ans As String
Dim i As Long, strWorkb As String, strWbName As String, strWbPath As String, nrStores As Long
strWorkb = "Please write the number of the workbook needed to be processed:" & vbCrLf & vbCrLf
For Each Wb In Workbooks
i = i + 1
strWorkb = strWorkb & Wb.name & " - " & i & vbCrLf
Next
strWorkb = left(strWorkb, Len(strWorkb) - 1)
Ans = InputBox(strWorkb, "Necessary workbook selection", 1)
If Ans = "" Then MsgBox "You did not select anything...", vbInformation, "No workbook selected": Exit Sub
If Not IsNumeric(Ans) Then
MsgBox "You must write the number from the right side of the needed workbook name!", vbInformation, _
"Wrong choice...": Exit Sub
ElseIf Ans > Workbooks.Count Then
MsgBox "You must write a number less or equal with " & Workbooks.Count, vbInformation, _
"Wrong chosen number": Exit Sub
End If
Set w = Workbooks(CLng(Ans))
On Error Resume Next
Set sh = w.Worksheets("aux")
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0
MsgBox "The chosen workbook looks to be wrong..." & vbCrLf & _
" Worksheet ""Tabela - Média Mensal"" is missing.", vbInformation, _
"Wrong workbook or necessary worksheet missing": Exit Sub
End If
On Error GoTo 0
strWbName = w.FullName
nrStores = sh.Range("AF2").End(xlDown).Row
Arr = sh.Range("AF2:AF" & nrStores)
w.Activate
i = 0
Application.Calculation = xlCalculationManual
For Each store In Arr
i = i + 1
Nova_loja strWbName, store, i, nrStores - 1
Next
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = "Ready..."
End Sub
Sub Nova_loja(strWbName As String, store As Variant, No As Long, NrPag As Long)
Dim sht As Worksheet, fName As String, Cell As Range, cRange As Range
Dim w As Workbook, Wb As Workbook, boolFound As Boolean, shortName As String
Dim Arr As Variant, shAr As Worksheet, shortWbName As String
shortWbName = Right(strWbName, Len(strWbName) - InStrRev(strWbName, "\"))
For Each Wb In Workbooks
If Wb.FullName = strWbName Then
Set w = Wb: boolFound = True: Exit For
End If
Next
If Not boolFound Then
Set w = Workbooks.Open(strWbName)
End If
Application.ScreenUpdating = False
Application.StatusBar = "Working on " & store & " store (" & No & " of " & NrPag & ")..."
Application.CalculateBeforeSave = True
Set shAr = Workbooks(shortWbName).Worksheets("aux")
Arr = shAr.Range("K44:L66")
shAr.Range("K44:L66") = Arr
Sheets("Tabela - Média Mensal").Range("B2").Value = store
Sheets("BD Geral").ListObjects("Table2").Range.AutoFilter field:=52, Criteria1:="<>" & store, _
Operator:=xlFilterValues
Application.DisplayAlerts = False
Sheets("BD Geral").ListObjects("Table2").DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Sheets("BD Geral").ListObjects("Table2").AutoFilter.ShowAllData 'it returns an error if no filter is applied
Application.DisplayAlerts = True
'filter and delete
Sheets("BD BONUS_MALUS").ListObjects("Table35").Range.AutoFilter field:=3, Criteria1:="<>" & Worksheets("Tabela - Média Mensal").Range("B1").Value, Operator:=xlFilterValues
Application.DisplayAlerts = False
Sheets("BD BONUS_MALUS").ListObjects("Table35").DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
Sheets("BD BONUS_MALUS").ListObjects("Table35").AutoFilter.ShowAllData
'filter and delete
Sheets("BD NPS").ListObjects("Table3").Range.AutoFilter field:=2, Criteria1:="<>" & Worksheets("Tabela - Média Mensal").Range("B1").Value, Operator:=xlFilterValues
Application.DisplayAlerts = False
Sheets("BD NPS").ListObjects("Table3").DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
Sheets("BD NPS").ListObjects("Table3").AutoFilter.ShowAllData
'This sheet does not contain any "Table"...
Sheets("BD Dept").ListObjects("Table4").Range.AutoFilter field:=8, Criteria1:="<>" & Worksheets("Tabela - Média Mensal").Range("B1").Value, Operator:=xlFilterValues
Application.DisplayAlerts = False
Sheets("BD Dept").ListObjects("Table4").DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
Sheets("BD Dept").ListObjects("Table4").AutoFilter.ShowAllData
'hide sheets
For Each sht In w.Worksheets
If sht.name <> "Dashboard" And sht.name <> "Tabela - Média Mensal" Then
sht.Visible = xlSheetVeryHidden
End If
Next sht
'protect sheets
For Each sht In ActiveWorkbook.Sheets
sht.Protect Password:="fnacrh", AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True
Next
'leave active main worksheet
Sheets("Dashboard").Select
w.RefreshAll
shortName = "02.VIM_REPORT MENSAL - " & store & " - " & Worksheets("aux").Range("V3") & ".xlsx"
fName = w.Path & "\" & shortName
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=fName, FileFormat:=xlWorkbookDefault
Workbooks(shortName).Close , False
Application.DisplayAlerts = True
Application.DisplayStatusBar = True
Application.ScreenUpdating = True
End Sub
Please, test it and confirm if it works as expected.
If not, mention what wrong happens.
Would that 'list of stores' be another excel workbook/sheet?
Do we have to deduce where the 'store' in discussion exists in your workbook?
Isn't it better you to describe where the change must be done?
Of course, this is not an answer but I do not know how else I can clarify the issue...
Sub AutomaticallySelectStore()
Dim W As Workbook, Sh As Worksheet, store As Variant, Arr As Variant
Set W = ActiveWorkbook
Set Sh = W.Worksheets("Tabela - Média Mensal")
Arr = Sh.Range("AF2:AF" & Sh.Range("AF2").SpecialCells(xlCellTypeLastCell).Row)
For Each store In Arr
Nova_loja store
Next
End Sub
Sub Nova_loja(store As Variant)
Dim sht As Worksheet, Fname As String, Cell As Range, cRange As Range
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
With Range("K44:L66")
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
End With
Application.CutCopyMode = False
'filter and delete
Sheets("BD Geral").Select
ActiveSheet.ListObjects("Table2").Range.AutoFilter Field:=52, Criteria1:="<>" & store, Operator:=xlFilterValues
Application.DisplayAlerts = False
ActiveSheet.ListObjects("Table2").DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
ActiveSheet.ListObjects("Table2").AutoFilter.ShowAllData
'filter and delete
Sheets("BD BONUS_MALUS").Select
ActiveSheet.ListObjects("Table35").Range.AutoFilter Field:=3, Criteria1:="<>" & Worksheets("Tabela - Média Mensal").Range("B1").Value, Operator:=xlFilterValues
Application.DisplayAlerts = False
ActiveSheet.ListObjects("Table35").DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
ActiveSheet.ListObjects("Table35").AutoFilter.ShowAllData
'filter and delete
Sheets("BD NPS").Select
ActiveSheet.ListObjects("Table3").Range.AutoFilter Field:=2, Criteria1:="<>" & Worksheets("Tabela - Média Mensal").Range("B1").Value, Operator:=xlFilterValues
Application.DisplayAlerts = False
ActiveSheet.ListObjects("Table3").DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
ActiveSheet.ListObjects("Table3").AutoFilter.ShowAllData
Sheets("BD Dept").Select
ActiveSheet.ListObjects("Table4").Range.AutoFilter Field:=8, Criteria1:="<>" & Worksheets("Tabela - Média Mensal").Range("B1").Value, Operator:=xlFilterValues
Application.DisplayAlerts = False
ActiveSheet.ListObjects("Table4").DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
ActiveSheet.ListObjects("Table4").AutoFilter.ShowAllData
'refresh pivots
ThisWorkbook.RefreshAll
'hide sheets
For Each sht In ThisWorkbook.Worksheets
If sht.Name <> "Dashboard" And sht.Name <> "Tabela - Média Mensal" Then
sht.Visible = xlSheetVeryHidden
End If
Next sht
'protect sheets
For Each sht In ActiveWorkbook.Sheets
sht.Protect Password:="fnacrh", AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True
Next
'leave active main worksheet
Sheets("Dashboard").Select
'save as with new name
Application.DisplayAlerts = False
Fname = ThisWorkbook.Path & "\" & "02.VIM_REPORT MENSAL - " & Worksheets("aux").Range("V2") & " - " & Worksheets("aux").Range("V3") & ".xlsx"
ActiveWorkbook.SaveAs Filename:=Fname, FileFormat:=xlWorkbookDefault
Application.DisplayAlerts = True
Application.DisplayStatusBar = True
Application.ScreenUpdating = True
End Sub
So, you must run 'AutomaticallySelectStore' procedure and wait...
I do not have such a file in order to test it, so, it is a code based only on VBA logic and my understanding about your situation.
Depending on how big are your workbooks it may load your system RAM and CPU, working continuously. I am waiting for some feedback.
The initial code can also be optimized a little, but let us see how it works now.