Copy worksheet in PDF and also Excel xlxs in to same folder.

M

Manchesterisred

New Member
Joined
Aug 20, 2021
Messages
17
Office Version
  1. 365
Platform
  1. 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
 

Excel Facts

When they said...
When they said you are going to "Excel at life", they meant you "will be doing Excel your whole life".
Sort by date Sort by votes
Try this:

VBA Code: 
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")
  If Dir(FolderName, vbDirectory) = "" Then
    MkDir FolderName
  End If
  
  '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)) & " " & _
                 Trim(CStr(WS.Range("E20").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
      
      If Dir(Path, vbDirectory) = "" Then
        MkDir Path
      End If
      
      FName = Path & "\" & WS.Name & " - " & CellData
      
      WS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FName & ".pdf"
      WS.Copy
      ActiveWorkbook.SaveAs FName & ".xlsx"
      ActiveWorkbook.Close False
    End Select
  Next WS
  
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
  End With
End Sub
 
Upvote 0
DanteAmor said:
Try this:

VBA Code: 
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")
  If Dir(FolderName, vbDirectory) = "" Then
    MkDir FolderName
  End If
 
  '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)) & " " & _
                 Trim(CStr(WS.Range("E20").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
    
      If Dir(Path, vbDirectory) = "" Then
[COLOR=rgb(147, 101, 184)][B]        MkDir Path[/B][/COLOR]
      End If
    
      FName = Path & "\" & WS.Name & " - " & CellData
    
      WS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FName & ".pdf"
      WS.Copy
      ActiveWorkbook.SaveAs FName & ".xlsx"
      ActiveWorkbook.Close False
    End Select
  Next WS
 
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
  End With
End Sub
Click to expand...
Hi Dante, Thanks for your help

Whn i tried to run the marco, i got a debug on the MkDir path

If Dir(Path, vbDirectory) = "" Then
MkDir Path

Do i need to change something ?
 
Upvote 0
What does the error message say?

At the time of execution, what values do you have in the cells: "B22" and "E20"

Note: Cell data to use in names. Must not contain illegal chars.
 
Upvote 0
DanteAmor said:
What does the error message say?

At the time of execution, what values do you have in the cells: "B22" and "E20"

Note: Cell data to use in names. Must not contain illegal chars.
Click to expand...


The message ia a run-time error 76

Path not found

Yes there are values currently in those cells
 
Upvote 0
It is very simple, what data do you have in the cells.
 
Upvote 0
Forget everything, if your macro works, then you only need to save the sheet as xlsx. So use this:

just add this lines:
VBA Code: 
'add this lines:
      WS.Copy
      ActiveWorkbook.SaveAs Sourcewb.Path & "\" & WS.Range("B22").Value & WS.Range("E20").Value & ".xlsx"
      ActiveWorkbook.Close False
'end add lines

VBA Code: 
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

'add this lines:
      WS.Copy
      ActiveWorkbook.SaveAs Sourcewb.Path & "\" & WS.Range("B22").Value & WS.Range("E20").Value & ".xlsx"
      ActiveWorkbook.Close False
'end add lines

End Select
Next WS

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
 
Upvote 0
DanteAmor said:
Forget everything, if your macro works, then you only need to save the sheet as xlsx. So use this:

just add this lines:
VBA Code: 
'add this lines:
      WS.Copy
      ActiveWorkbook.SaveAs Sourcewb.Path & "\" & WS.Range("B22").Value & WS.Range("E20").Value & ".xlsx"
      ActiveWorkbook.Close False
'end add lines

VBA Code: 
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

'add this lines:
      WS.Copy
      ActiveWorkbook.SaveAs Sourcewb.Path & "\" & WS.Range("B22").Value & WS.Range("E20").Value & ".xlsx"
      ActiveWorkbook.Close False
'end add lines

End Select
Next WS

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Click to expand...

Thank you - Ive copied this in and it creates the master folder and the sub folder and saves the PDF in the sub folder,. It then copies the worksheet on to a new excel sheet but then fails to save.

I got a runtime 1004 error on this line " ActiveWorkbook.SaveAs Sourcewb.Path & "\" & WS.Range("B22").Value & WS.Range("E20").Value & ".xlsx""

Method " Save As of object_workbook failed

So everything was good but up until this point - Does the marco need any adjustment ?
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Solved
Add a sequence to the workbook if the same name is found when saving
Replies
8
Views
277
Alex Blakenburg
A
M
  • Question
Excel VBA Save PDF within workbook folder and send as email attachment
Replies
1
Views
202
rpaulson
rpaulson
J
  • Solved
File save prompt for location
Replies
3
Views
266
Domenic
D
M
  • Solved
PDF's won't open in Sharepoint/Teams but will in C:drive Documents folder
Replies
3
Views
684
Mr_Ragweed2
M
S
  • Question
Excel VBA to email multiple ranges as a PDF
Replies
0
Views
652
shophoney
S

Forum statistics

Threads
1,214,645
Messages
6,120,711
Members
448,984
Latest member
foxpro

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top