Macro para guardar las copias donde seleccione en el dialogo

Pon la macro y procura explicarme con más detalle lo que necesitas, utiliza ejemplos reales y claros.

La macro esta para que guarde (copie XLSX y PDF) en determinada ruta (D:|Datos Mecánicos), bien por aquí.

Quiero que antes de guardar, aibra el dialogo para que yo pueda seleccionar la carpeta destino, porque ni siempre es D:\Datos Mecánicos. Entonces guarda y tengo que ir a la carpeta y meterlas en la carpeta que corresponde

Sub GuardaSinMacros() 'guarda una copia .xlsx TOTALMENTE protegida, una copia PDF, elimina botones,
'desprotege y protege la origen
    Dim ruta    As String
    Dim nombre  As String
    Dim wb      As Object
    Dim i       As Long
    Dim d       As String
    ruta = "D:\Datos Mecanicos\"
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    ActiveSheet.Unprotect "By Jot@"
    With ThisWorkbook.Sheets(1)
    Set h1 = ActiveSheet
        nombre = Ini(Quitar(.Range("G4"))) & "_" & h1.Name & " " & .Range("H3") & Format(.Range("I3"), "0000") & _
        " " & .Range("D11") & "_" & .Range("C13") & "_" & .Range("H13").Value
'xxxxxxxxxxxxxxxxxx
 'El cuadro dialogo abre en la carpeta de rut Guardar copia desde el cuadro dialogo
    With Application.FileDialog(msoFileDialogFolderPicker) 'Abre el cuadro dialogo
        .Title = "Selecciona destino"
        .AllowMultiSelect = False
        .InitialFileName = rut
'Si cancela sale de la macro
        If .Show <> -1 Then Exit Sub
        cp = .SelectedItems(1)
    End With
'xxxxxxxxxxxxxxxxxxxx
        .Copy
    End With
    Set wb = Workbooks(Workbooks.Count)
    With wb
        With .Sheets(1)
            For i = .Shapes.Count To 1 Step -1
                d = .Shapes(i).TopLeftCell.Address(False, False)
                Select Case d
                    Case "J2": .Shapes(i).Delete
                    Case "J3": .Shapes(i).Delete
                    Case "L3": .Shapes(i).Delete
                    Case "L5": .Shapes(i).Delete
                End Select
            Next
            .SaveAs Filename:=ruta & nombre & ".xlsx", FileFormat:=xlOpenXMLWorkbook, _
                CreateBackup:=False
            With .Range("B2:J60")
                .ExportAsFixedFormat Type:=xlTypePDF, Filename:=ruta & nombre & ".pdf", _
                                     Quality:=xlQualityStandard, IncludeDocProperties:=True, _
                                     IgnorePrintAreas:=False, OpenAfterPublish:=False
                .Copy
                .PasteSpecial xlPasteValues
                Application.CutCopyMode = False
                Range("A2").Select 'DEseleccionar el rango en la copia
            End With
            With .Cells
                .Locked = True
                .FormulaHidden = False
            End With
            .Protect Password:="By Jot@", DrawingObjects:=True, Contents:=True, Scenarios:=True
            .EnableSelection = xlNoSelection 'Restringe todo, seleccion y escritura
        End With
        .SaveAs Filename:=ruta & nombre & ".xlsx", FileFormat:=xlOpenXMLWorkbook, _
                CreateBackup:=False
        .Close True
    End With
    Set wb = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    With ThisWorkbook
        With .Sheets(1).Range("I3")
            .Value = .Value + 1
        End With
    End With
    ActiveSheet.Protect "By Jot@"
    MsgBox "Copiado archivo " & nombre & " en " & ruta
End Sub

Meterle la parte que esta entre xs

'xxxxxxxxxxxxx

A ver si tuve suerte en explicarte lo que quiero

Creo que el detalle esta por aquí

        If .Show <> -1 Then Exit Sub
        cp = .SelectedItems(1)

Abre el dialogo pero sigue guardando en D:\Datos mecanicos aunque en el dialogo yo seleccione otra carpeta

Cambia esta línea

cp = .SelectedItems(1)

Por esta:

ruta = .SelectedItems(1) & "\"

sal u dos

La letra roja hay que meterla? porque solo es rut como la macro donde copie esta parte de la macro

'XXXXXXXX
'El cuadro dialogo abre en la carpeta de rut Guardar copia desde el cuadro dialogo
    With Application.FileDialog(msoFileDialogFolderPicker) 'Abre el cuadro dialogo
        .Title = "Selecciona destino"
        .AllowMultiSelect = False
        .InitialFileName = rut
'Si cancela sale de la macro
        If .Show <> -1 Then Exit Sub
        ruta = .SelectedItems(1) & "\"
    End With
'XXXXXXXX

Irá asi?

 .InitialFileName = ruta

De una o otra forma funciona bien pero no entiendo porque funciona rut o ruta

Debe ser ruta

Gracias Dante

Que pases bien y Dios te bendiga