Manchesterisred
New Member
- Joined
- Aug 20, 2021
- Messages
- 17
- Office Version
- 365
- Platform
- Windows
Hi There, Can anyone help me with this ?
I currently have this macro which copies the excel worksheet in to their individual folder in PDF format under 1 master folder.
At the same time of copying the PDF, i also need it to make an save a copy of the same worksheet but in xlxs format into the same folder - Can anyone suggest how this should be written ?
One final thing - i need the PDF and the excel file to both also pick up cell "E20" [ at the moment it only picks up cell "B22" to make the title
Any help would be greatly appreciated
Sub DDPDF()
'
' Direct debit Letters convert excel to PDF and save to drive
'
Dim Sourcewb As Workbook
Dim WS As Worksheet
Dim DateString As String
Dim FolderName As String, Path As String, FName As String
Dim CellData As String
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationAutomatic
End With
'Copy every sheet from the workbook with this macro
Set Sourcewb = ThisWorkbook
'Create new MASTER folder to save the new files in
DateString = Format(Now, "yyyy-mm-dd")
FolderName = Sourcewb.Path & "\" & Format(Sourcewb.Worksheets("DD").Range("C38"), "0") & " - Direct Debit Letters - " & Format(Sourcewb.Worksheets("DD").Range("D38"), "dd.mm.yyyy") & " dated " & Format(Sourcewb.Worksheets("DD").Range("C32"), "dd.mm.yyyy")
MkDir FolderName
'Loop through all worksheets and save as individual PDF in same folder as the Excel file
For Each WS In ActiveWorkbook.Worksheets
Select Case WS.Name
Case "Instructions", "DDsap", "DD", "DDclean", "Company", "EUR", "GBP", "USD" 'This is the worksheet ignore list. Edit as needed
Case Else
CellData = Trim(CStr(WS.Range("B22").Value)) 'Cell data to use in names. Must not contain illegal chars.
'Create new INDIVIDUAL file folder to save the new file in
Path = FolderName & "\" & WS.Name & " - " & CellData
MkDir Path
FName = Path & "\" & WS.Name & " - " & CellData & ".pdf"
WS.ExportAsFixedFormat Type:=xlTypePDF, FileName:=FName
End Select
Next WS
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
I currently have this macro which copies the excel worksheet in to their individual folder in PDF format under 1 master folder.
At the same time of copying the PDF, i also need it to make an save a copy of the same worksheet but in xlxs format into the same folder - Can anyone suggest how this should be written ?
One final thing - i need the PDF and the excel file to both also pick up cell "E20" [ at the moment it only picks up cell "B22" to make the title
Any help would be greatly appreciated
Sub DDPDF()
'
' Direct debit Letters convert excel to PDF and save to drive
'
Dim Sourcewb As Workbook
Dim WS As Worksheet
Dim DateString As String
Dim FolderName As String, Path As String, FName As String
Dim CellData As String
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationAutomatic
End With
'Copy every sheet from the workbook with this macro
Set Sourcewb = ThisWorkbook
'Create new MASTER folder to save the new files in
DateString = Format(Now, "yyyy-mm-dd")
FolderName = Sourcewb.Path & "\" & Format(Sourcewb.Worksheets("DD").Range("C38"), "0") & " - Direct Debit Letters - " & Format(Sourcewb.Worksheets("DD").Range("D38"), "dd.mm.yyyy") & " dated " & Format(Sourcewb.Worksheets("DD").Range("C32"), "dd.mm.yyyy")
MkDir FolderName
'Loop through all worksheets and save as individual PDF in same folder as the Excel file
For Each WS In ActiveWorkbook.Worksheets
Select Case WS.Name
Case "Instructions", "DDsap", "DD", "DDclean", "Company", "EUR", "GBP", "USD" 'This is the worksheet ignore list. Edit as needed
Case Else
CellData = Trim(CStr(WS.Range("B22").Value)) 'Cell data to use in names. Must not contain illegal chars.
'Create new INDIVIDUAL file folder to save the new file in
Path = FolderName & "\" & WS.Name & " - " & CellData
MkDir Path
FName = Path & "\" & WS.Name & " - " & CellData & ".pdf"
WS.ExportAsFixedFormat Type:=xlTypePDF, FileName:=FName
End Select
Next WS
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub