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

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

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,916
Office Version
  1. 2007
Platform
  1. Windows
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
 

Manchesterisred

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

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,916
Office Version
  1. 2007
Platform
  1. Windows
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.
 

Manchesterisred

New Member
Joined
Aug 20, 2021
Messages
17
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

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.


The message ia a run-time error 76

Path not found

Yes there are values currently in those cells
 

Manchesterisred

New Member
Joined
Aug 20, 2021
Messages
17
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

You could be explicit, I mean that you must put exactly the content of those cells here.
Hi Dante, sorry im not sure what you mean
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,916
Office Version
  1. 2007
Platform
  1. Windows
It is very simple, what data do you have in the cells.
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,916
Office Version
  1. 2007
Platform
  1. Windows
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
 

Manchesterisred

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

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 ?
 

Forum statistics

Threads
1,147,632
Messages
5,742,228
Members
423,714
Latest member
ftp2jz

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
Top