У меня проблема с приведенным ниже кодом. Лист «Ca sh Flow» не изменит высоту, чтобы поместиться на одной странице. Когда я использую точку останова, она работает, но эта строка кажется пропущенной при запуске макроса. Я пробовал использовать Application.Wait, но это не сработало. Есть мысли о том, как это исправить? Заранее благодарим!
Раздел кода, который не работает:
Sheets("Cash Flow").Select
With ActiveSheet.PageSetup
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
Полный код:
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
`enter code here` If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xls*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'Sets Page Height ad Width
Dim myArray() As Variant
Dim i As Integer
For i = 1 To Sheets.Count
ReDim Preserve myArray(i - 1)
myArray(i - 1) = i
Next i
Sheets(myArray).Select
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 0
End With
Sheets("Cash Flow").Select
With ActiveSheet.PageSetup
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"
strName = CreateObject("Scripting.FileSystemObject").GetBaseName(ActiveWorkbook.Name)
'create default name for savng file
strFile = strName & ".pdf"
strPathFile = strPath & strFile
'export to PDF in current folder
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=strPathFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
'Save and Close Workbook
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub