VBA Save to 2 locations including Users desktop

[michelle 1]

Dear ALL

is it possible to add to the below code a step that will also save to the users desktop. I have replaced the current location with XX just for privacy purposes.

Public Sub MASSUPLOAD()
    
    Dim newWb As Workbook
    Dim wbConn As WorkbookConnection
    Dim wbQuery As WorkbookQuery
    Dim links As Variant, i As Long
    
    ThisWorkbook.Worksheets(Array("Patient Fields", "Sheet1")).Copy
    Set newWb = ActiveWorkbook
    
    'Delete workbook connections
    
    For Each wbConn In newWb.Connections
        wbConn.Delete
    Next
    
    'Delete workbook queries
    
    For Each wbQuery In newWb.Queries
        wbQuery.Delete
    Next
    
    'Delete Excel links
    
    'links = newWb.LinkSources(xlExcelLinks)
    'If links <> Empty Then
     '   For i = 1 To UBound(links)
      '      newWb.BreakLink links(i), xlLinkTypeExcelLinks
       ' Next
    'End If
    
    Worksheets(Array("Patient Fields")).Select
    Range("A3").Select
    ActiveSheet.Shapes.Range(Array("Rectangle: Rounded Corners 2")).Select '
    Selection.Delete
    Selection.Cut
    
    Application.DisplayAlerts = False 'suppress warning message displayed if new workbook already exists
    newWb.SaveAs "XXXXX/" & "\" & "XXXX_" & Format$(Now(), "YYmmdd_hhmmss") & ".xlsx", FileFormat:=xlOpenXMLWorkbook
    Application.DisplayAlerts = True
    newWb.Close False
    
End Sub

[mjr veverka]

???

Option Explicit

Public Sub MASSUPLOAD_01()
    Dim elmnt As Variant, i As Long
    
    ThisWorkbook.Worksheets(Array("Patient Fields", "Sheet1")).Copy
        With ActiveWorkbook
            With .Worksheets("Patient Fields")
                .Shapes.Range("Rectangle: Rounded Corners 2").Delete
                .Range("A3").Delete
            End With
            For Each elmnt In .Queries
                elmnt.Delete
            Next
            For Each elmnt In .Connections
                elmnt.Delete
            Next
            'elmnt = .LinkSources(xlExcelLinks)
            'If elmnt <> Empty Then
            '   For i = LBound(elmnt) To UBound(elmnt)
            '      .BreakLink elmnt(i), xlLinkTypeExcelLinks
            '   Next
            'End If
            elmnt = CreateObject("Wscript.Shell").SpecialFolders("Desktop")
            .SaveAs elmnt & "\" & Format$(Now(), "YYmmdd_hhmmss") & ".xlsx", FileFormat:=51
            .Close False
        End With
    DoEvents
End Sub

[michelle 1]

Thankyou this does save to my desktop but i now have 2 buttons one that is saving to my desktop and one to the folder is there anyway to combine the code so its all done via one button?

[protonLeah]

You need lines something like:

    ChDir "C:\Users\ben\Desktop"
    ActiveWorkbook.SaveAs Filename:= ...

[jdelano]

Try using SaveCopyAs after your

.SaveAs elmnt & "\" & Format$(Now(), "YYmmdd_hhmmss") & ".xlsx", FileFormat:=51

Put

.SaveCopyAs Environ("USERPROFILE") & "\Desktop\" & Format$(Now(), "YYmmdd_hhmmss") & ".xlsx"

https://learn.microsoft.com/en-us/of...ook.SaveCopyAs

EDIT: You'll want to just combine that one SaveAsCopy line to the button that saves the first file