Dear all,
I have taken this VBA from the internet and it works well. I am wondering if this code code could be altered so that it makes each file into a word file rather than a PDF.
Is it possible?
Sub SaveEachWorkSheetToWorkbookInMacExcel2016()
'Ron de Bruin : 19-June-2018
'It will create a new folder for you with the files
Dim FolderName As String
Dim Folderstring As String
Dim Fstr As String
Dim TestStr As String
Dim sh As Worksheet
Dim FileName As String
Dim FilePathName As String
Dim Sourcewb As Workbook
Dim Destwb As Workbook
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Name of the Root folder in the Office folder, and create the folder
FolderName = "ExcelSaveFolder"
Folderstring = CreateFolderinMacOffice2016(NameFolder:=FolderName)
'Create folder in the Root folder with the name of the ActiveWorkbook
Fstr = Mid(ActiveWorkbook.Name, 1, InStrRev(ActiveWorkbook.Name, ".", , 1) - 1) & Format(Now, " dd-mmm-yyyy hh-mm-ss")
On Error Resume Next
TestStr = Dir(Folderstring & "/" & Fstr, vbDirectory)
On Error GoTo 0
If TestStr = vbNullString Then MkDir Folderstring & "/" & Fstr
'set reference to the Active Workbook
Set Sourcewb = ActiveWorkbook
For Each sh In ActiveWorkbook.Worksheets
'If the sheet is visible then publish it to PDF
If sh.Visible = -1 Then
sh.Copy
Set Destwb = ActiveWorkbook
'Determine file extension/format
With Destwb
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .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 With
' 'Change all cells in the worksheet to values if you want
' With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False
'Name the file and Save it
FileName = sh.Name & " " & "2019-20 Parent Teacher Conference Record" & " " & Format(Now, "dd-mmm-yyyy hh-mm-ss")
With Destwb
.SaveAs Folderstring & Application.PathSeparator & Fstr & Application.PathSeparator & FileName & _
FileExtStr, FileFormat:=FileFormatNum
End With
'Close the file
Destwb.Close False
End If
Next sh
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "You find the Excel files in this location : " & Folderstring & "/" & Fstr
End Sub
Sub PublishEachWorkSheetToPDFInMacExcel2016()
'Ron de Bruin : 29-July-2017
'Test macro to publish each worksheet to pdf with ExportAsFixedFormat
'Note : if set it save the printarea
'It will create a new folder for you with the files
Dim FolderName As String
Dim Folderstring As String
Dim Fstr As String
Dim TestStr As String
Dim sh As Worksheet
Dim FileName As String
Dim FilePathName As String
'Name of the Root folder in the Office folder, and create the folder
FolderName = "PDFSaveFolder"
Folderstring = CreateFolderinMacOffice2016(NameFolder:=FolderName)
'Create folder in the Root folder with the name of the ActiveWorkbook
Fstr = Mid(ActiveWorkbook.Name, 1, InStrRev(ActiveWorkbook.Name, ".", , 1) - 1) & Format(Now, " dd-mmm-yyyy hh-mm-ss")
On Error Resume Next
TestStr = Dir(Folderstring & "/" & Fstr, vbDirectory)
On Error GoTo 0
If TestStr = vbNullString Then MkDir Folderstring & "/" & Fstr
'Loop through all worksheets
For Each sh In ActiveWorkbook.Worksheets
'If the sheet is visible then publish it to PDF
If sh.Visible = -1 Then
sh.PageSetup.Orientation = sh.PageSetup.Orientation
'File name is the sheet name and a date/time stamp
FileName = sh.Name & " " & "2020-21 Parent Teacher Conference Record" & ".pdf"
'Publish the Worksheet to pdf
FilePathName = Folderstring & Application.PathSeparator & Fstr & Application.PathSeparator & FileName
'expression A variable that represents a Workbook, Sheet, Chart, or Range object.
'the parameters are not working like in Excel for Windows
sh.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
FilePathName, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False
End If
Next sh
MsgBox "You find the PDF files in this location : " & Folderstring & "/" & Fstr
End Sub
Function CreateFolderinMacOffice2016(NameFolder As String) As String
'Function to create folder if it not exists in the Microsoft Office Folder
'Ron de Bruin : 8-Jan-2016
Dim OfficeFolder As String
Dim PathToFolder As String
Dim TestStr As String
OfficeFolder = MacScript("return POSIX path of (path to desktop folder) as string")
OfficeFolder = Replace(OfficeFolder, "/Desktop", "") & _
"Library/Group Containers/UBF8T346G9.Office/"
PathToFolder = OfficeFolder & NameFolder
On Error Resume Next
TestStr = Dir(PathToFolder, vbDirectory)
On Error GoTo 0
If TestStr = vbNullString Then
MkDir PathToFolder
'You can use this msgbox line for testing if you want
'MsgBox "You find the new folder in this location :" & PathToFolder
End If
CreateFolderinMacOffice2016 = PathToFolder
End Function
Thank you.
I have taken this VBA from the internet and it works well. I am wondering if this code code could be altered so that it makes each file into a word file rather than a PDF.
Is it possible?
Sub SaveEachWorkSheetToWorkbookInMacExcel2016()
'Ron de Bruin : 19-June-2018
'It will create a new folder for you with the files
Dim FolderName As String
Dim Folderstring As String
Dim Fstr As String
Dim TestStr As String
Dim sh As Worksheet
Dim FileName As String
Dim FilePathName As String
Dim Sourcewb As Workbook
Dim Destwb As Workbook
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Name of the Root folder in the Office folder, and create the folder
FolderName = "ExcelSaveFolder"
Folderstring = CreateFolderinMacOffice2016(NameFolder:=FolderName)
'Create folder in the Root folder with the name of the ActiveWorkbook
Fstr = Mid(ActiveWorkbook.Name, 1, InStrRev(ActiveWorkbook.Name, ".", , 1) - 1) & Format(Now, " dd-mmm-yyyy hh-mm-ss")
On Error Resume Next
TestStr = Dir(Folderstring & "/" & Fstr, vbDirectory)
On Error GoTo 0
If TestStr = vbNullString Then MkDir Folderstring & "/" & Fstr
'set reference to the Active Workbook
Set Sourcewb = ActiveWorkbook
For Each sh In ActiveWorkbook.Worksheets
'If the sheet is visible then publish it to PDF
If sh.Visible = -1 Then
sh.Copy
Set Destwb = ActiveWorkbook
'Determine file extension/format
With Destwb
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .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 With
' 'Change all cells in the worksheet to values if you want
' With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False
'Name the file and Save it
FileName = sh.Name & " " & "2019-20 Parent Teacher Conference Record" & " " & Format(Now, "dd-mmm-yyyy hh-mm-ss")
With Destwb
.SaveAs Folderstring & Application.PathSeparator & Fstr & Application.PathSeparator & FileName & _
FileExtStr, FileFormat:=FileFormatNum
End With
'Close the file
Destwb.Close False
End If
Next sh
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "You find the Excel files in this location : " & Folderstring & "/" & Fstr
End Sub
Sub PublishEachWorkSheetToPDFInMacExcel2016()
'Ron de Bruin : 29-July-2017
'Test macro to publish each worksheet to pdf with ExportAsFixedFormat
'Note : if set it save the printarea
'It will create a new folder for you with the files
Dim FolderName As String
Dim Folderstring As String
Dim Fstr As String
Dim TestStr As String
Dim sh As Worksheet
Dim FileName As String
Dim FilePathName As String
'Name of the Root folder in the Office folder, and create the folder
FolderName = "PDFSaveFolder"
Folderstring = CreateFolderinMacOffice2016(NameFolder:=FolderName)
'Create folder in the Root folder with the name of the ActiveWorkbook
Fstr = Mid(ActiveWorkbook.Name, 1, InStrRev(ActiveWorkbook.Name, ".", , 1) - 1) & Format(Now, " dd-mmm-yyyy hh-mm-ss")
On Error Resume Next
TestStr = Dir(Folderstring & "/" & Fstr, vbDirectory)
On Error GoTo 0
If TestStr = vbNullString Then MkDir Folderstring & "/" & Fstr
'Loop through all worksheets
For Each sh In ActiveWorkbook.Worksheets
'If the sheet is visible then publish it to PDF
If sh.Visible = -1 Then
sh.PageSetup.Orientation = sh.PageSetup.Orientation
'File name is the sheet name and a date/time stamp
FileName = sh.Name & " " & "2020-21 Parent Teacher Conference Record" & ".pdf"
'Publish the Worksheet to pdf
FilePathName = Folderstring & Application.PathSeparator & Fstr & Application.PathSeparator & FileName
'expression A variable that represents a Workbook, Sheet, Chart, or Range object.
'the parameters are not working like in Excel for Windows
sh.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
FilePathName, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False
End If
Next sh
MsgBox "You find the PDF files in this location : " & Folderstring & "/" & Fstr
End Sub
Function CreateFolderinMacOffice2016(NameFolder As String) As String
'Function to create folder if it not exists in the Microsoft Office Folder
'Ron de Bruin : 8-Jan-2016
Dim OfficeFolder As String
Dim PathToFolder As String
Dim TestStr As String
OfficeFolder = MacScript("return POSIX path of (path to desktop folder) as string")
OfficeFolder = Replace(OfficeFolder, "/Desktop", "") & _
"Library/Group Containers/UBF8T346G9.Office/"
PathToFolder = OfficeFolder & NameFolder
On Error Resume Next
TestStr = Dir(PathToFolder, vbDirectory)
On Error GoTo 0
If TestStr = vbNullString Then
MkDir PathToFolder
'You can use this msgbox line for testing if you want
'MsgBox "You find the new folder in this location :" & PathToFolder
End If
CreateFolderinMacOffice2016 = PathToFolder
End Function
Thank you.
