'Export Excel tabs and set page formatting at same time
I have some existing VBA code that works great for exporting all tabs in my workbook as individual sheets named by the tab name. I just want to be able to set the page formatting before it saves each new workbook. I have tried to insert the following code but it is not working. Any help is appreciated.
'set page formatting
With ActiveSheet.PageSetup
.printArea = "$A$1:$L$32"
.FitToPagesWide = 1
.FitToPagesTall = 1
.Orientation = xlLandscape
End With
Below is existing code that works fine:
Sub split_to_seperate_sheets()
Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
MyFilePath$ = ActiveWorkbook.Path & "\" & _
Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
With Application
.ScreenUpdating = False
.DisplayAlerts = False
' End With
On Error Resume Next '<< a folder exists
MkDir MyFilePath '<< create a folder
For N = 1 To Sheets.Count
Sheets(N).Activate
SheetName = ActiveSheet.Name
Cells.Copy
Workbooks.Add (xlWBATWorksheet)
With ActiveWorkbook
With .ActiveSheet
.Paste
.Name = SheetName
[A1].Select
End With
'save book in this folder
.SaveAs FileName:="C:\Seasonal Brochures\Price Pages\2022 May\" & SheetName & ".xlsx"
.Close SaveChanges:=True
End With
.CutCopyMode = False
Next
End With
Sheet1.Activate
End Sub
Solution 1:[1]
So after searching around I found a different VBA code that does the job and I will post below. It seems to export the tabs formatted as they are.
Sub SplitWorkbook()
'Updateby20200806
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim xWs As Worksheet
Dim xWb As Workbook
Dim xNWb As Workbook
Dim FolderName As String
Application.ScreenUpdating = False
Set xWb = Application.ThisWorkbook
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = xWb.Path & "\" & xWb.Name & " " & DateString
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
Select Case xWb.FileFormat
Case 51:
FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If Application.ActiveWorkbook.HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56:
FileExtStr = ".xls": FileFormatNum = 56
Case Else:
FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
MkDir FolderName
For Each xWs In xWb.Worksheets
On Error GoTo NErro
If xWs.Visible = xlSheetVisible Then
xWs.Select
xWs.Copy
xFile = FolderName & "\" & xWs.Name & FileExtStr
Set xNWb = Application.Workbooks.Item(Application.Workbooks.Count)
xNWb.SaveAs xFile, FileFormat:=FileFormatNum
xNWb.Close False, xFile
End If
NErro:
xWb.Activate
Next
MsgBox "You can find the files in " & FolderName
Application.ScreenUpdating = True
End Sub
Sources
This article follows the attribution requirements of Stack Overflow and is licensed under CC BY-SA 3.0.
Source: Stack Overflow
Solution | Source |
---|---|
Solution 1 | Andy Mo |