Overwrite existing files and save as PDF XLSM and new sheet

[Rasmusjc]

Hi

I have this save button, that saves:

• 3 sheets into pdf
• 4 sheets into a new workbook (xlsm)
• 1 sheet into a new copy inside the workbook

My problem is if i want to save the sheets again it dosn't overwrite the old one.

So my question is how to change the code so it overwrite existing files if necessary?

Here is my code

Sub Gemsom() 
 
Dim fName As String
With Worksheets("Prisliste")
    fName = ThisWorkbook.Worksheets("Prisliste").Range("D1").Value & ThisWorkbook.Worksheets("Prisliste").Range("E10").Value & ThisWorkbook.Worksheets("Prisliste").Range("D4").Value
End With
Worksheets("Tilbud").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
            "C:\Users\rasmu\Desktop\2019\Tilbud\" & fName, Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
            
Worksheets("Lejekontrakt").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
            "C:\Users\rasmu\Desktop\2019\Lejekontrakt\" & fName, Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
            
Worksheets("Faktura").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
            "C:\Users\rasmu\Desktop\2019\Faktura\" & fName, Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
            
            
    Sheets(Array("Prisliste", "Tilbud", "Lejekontrakt", "Faktura")).Copy
    'there is now a new active workbook
    With ActiveWorkbook
        'save it
        .SaveAs Filename:= _
        "C:\Users\rasmu\Desktop\2019\" & ThisWorkbook.Worksheets("Prisliste").Range("D1").Value & ThisWorkbook.Worksheets("Prisliste").Range("E10").Value & ThisWorkbook.Worksheets("Prisliste").Range("D4").Value, FileFormat:=52
        'optionally close it
        .Close savechanges:=True
    End With




End Sub

 

[Yongle]

try adding these 2 lines:

[COLOR=#b22222]Application.DisplayAlerts = False[/COLOR]
        'save it
        .SaveAs Filename:= _
        "C:\Users\rasmu\Desktop\2019\" & ThisWorkbook.Worksheets("Prisliste").Range("D1").Value & ThisWorkbook.Worksheets("Prisliste").Range("E10").Value & ThisWorkbook.Worksheets("Prisliste").Range("D4").Value, FileFormat:=52
        'optionally close it
        .Close savechanges:=True
[COLOR=#b22222]Application.DisplayAlerts = True[/COLOR]

 

[Rasmusjc]

Thanks Yongle

If works for the PDF files and the new workbook.

I dont know why i forgot to paste the code for "save"

• 1 sheet into a new copy inside the workbook

Is it possible to do the same with this code so it just overwrite if the sheet allready excist

             Dim ws As Worksheet    Set wh = Worksheets(ActiveSheet.Name)
    ActiveSheet.Copy After:=Worksheets(Sheets.Count)
    If wh.Range("D1").Value <> "" Then
    ActiveSheet.Name = wh.Range("D1").Value
    End If
    wh.Activate

 

[ZVI]

Hi,
Try this:

Sub Test()
  Dim ws As Worksheet
  Set ws = ActiveSheet
  Application.ScreenUpdating = False
  ws.Copy After:=Worksheets(Sheets.Count)
  If ws.Range("D1").Value <> "" Then
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets(ws.Range("D1").Value).Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    ActiveSheet.Name = ws.Range("D1").Value
  End If
  ws.Activate
  Application.ScreenUpdating = True
End Sub

Regards

 

[Rasmusjc]

Hi,
Try this:

Sub Test()
  Dim ws As Worksheet
  Set ws = ActiveSheet
  Application.ScreenUpdating = False
  ws.Copy After:=Worksheets(Sheets.Count)
  If ws.Range("D1").Value <> "" Then
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets(ws.Range("D1").Value).Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    ActiveSheet.Name = ws.Range("D1").Value
  End If
  ws.Activate
  Application.ScreenUpdating = True
End Sub

Regards

Get a bug, saying name allready exist.

 

[Rasmusjc]

Can anyone help me out on this on?

Google cannot, unfortunately.

 

[ZVI]

May be this then:

Sub Test1()
  Dim ws As Worksheet, n As String
  Set ws = ActiveSheet
  n = ws.Range("D1").Value
  If Len(n) = 0 Then
    MsgBox "D1 is empty", vbCritical, "Exit"
    Exit Sub
  End If
  Application.ScreenUpdating = False
  ws.Copy After:=Worksheets(Sheets.Count)
  On Error Resume Next
  Application.DisplayAlerts = False
  Sheets(n).Delete
  Application.DisplayAlerts = True
  Sheets(Sheets.Count).Name = n
  If Not ws Is Nothing Then ws.Activate
  On Error GoTo 0
  Application.ScreenUpdating = True
End Sub

The sheet's name in D1 should be valid, of course.

 

[Rasmusjc]

Thanks Vladimir

That did it

Now everything is set for 2019.

Im very pleased with the help in here. I will be saving a lot of time in the future.

So thanks to all of you, who are taking your time to help.

 

[ZVI]

Happy to know the issue is solved and thank you for the feedback!

 

[Rasmusjc]

Hi Vladimir

Im having issus with the code you helped me with.

Just to point out how it works.

If i push the "Safe to pdf" button:

1) The sheet "prisliste" then copy it self to a new sheet with the name in "D1".
2) 3 sheets "tilbud" "lejekontrakt" "faktura" saves as pdf in different folders.
3) The "prisliste" "tilbud" "lejekontrakt" and "faktura" sheets copy to a new workbook with the name in D1 and D4

This works fine.

But if i change some of the data i the new created workbook to make new PDF files it open the original workbook and takes the data from this "prisliste" and not from the "prisliste" inside the new workbook.

Im not sure if its because the "Safe as pdf" macro not are beeing copied correctly or where the fault is.

Vladimir do you think you can help me with this, not sure if the easiest would be to upload the entire worksheet so you can se what i mean.

This is the code in the main workbook in the sheet "prisliste"

Private Sub GemsomPDF() 
 
Dim fName As String
With Worksheets("Prisliste")
    fName = ThisWorkbook.Worksheets("Prisliste").Range("D1").Value & ThisWorkbook.Worksheets("Prisliste").Range("E10").Value & ThisWorkbook.Worksheets("Prisliste").Range("D4").Value
End With
Worksheets("Tilbud").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
            "C:\Users\rasmus\Desktop\Fårvangtelt\2019\Tilbud\" & fName, Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
            
Worksheets("Lejekontrakt").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
            "C:\Users\rasmus\Desktop\Fårvangtelt\2019\Lejekontrakt\" & fName, Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
            
Worksheets("Faktura").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
            "C:\Users\rasmus\Desktop\Fårvangtelt\2019\Faktura\" & fName, Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
            


  Dim ws As Worksheet, n As String
  Set ws = ActiveSheet
  n = ws.Range("D1").Value
  If Len(n) = 0 Then
    MsgBox "D1 is empty", vbCritical, "Exit"
    Exit Sub
  End If
  Application.ScreenUpdating = False
  ws.Copy After:=Worksheets(Sheets.Count)
  On Error Resume Next
  Application.DisplayAlerts = False
  Sheets(n).Delete
  Application.DisplayAlerts = True
  Sheets(Sheets.Count).Name = n
  If Not ws Is Nothing Then ws.Activate
  On Error GoTo 0
  Application.ScreenUpdating = True


            
    Sheets(Array("Prisliste", "Tilbud", "Lejekontrakt", "Faktura")).Copy
    'there is now a new active workbook
    With ActiveWorkbook
        'save it
        .SaveAs Filename:= _
        "C:\Users\rasmus\Desktop\Fårvangtelt\2019\" & ThisWorkbook.Worksheets("Prisliste").Range("D1").Value & ThisWorkbook.Worksheets("Prisliste").Range("E10").Value & ThisWorkbook.Worksheets("Prisliste").Range("D4").Value, FileFormat:=52
        'optionally close it
        .Close savechanges:=True
    End With