Como comprimir archivo luego de hacer un backup

Compañero Ronald, el siguiente procedimiento recibe el path del archivo a comprimir (incluido el nombre del archivo) como parámetro para tal objetivo.

Solution:

 Sub ComprimirArchivo(RutaArchivo)
    'Ron de Bruin, Credits.
    If Dir(RutaArchivo) = "" Then
        MsgBox "El archivo a comprimir no existe", vbCritical, "Ruta de archivo inválida"
        Exit Sub
    End If
    RutaZIP = Left(RutaArchivo, InStrRev(RutaArchivo, ".") - 1) & Format(Now, "mdyyhmmss") & ".zip"
    If Dir(RutaZIP) <> "" Then Kill RutaZIP
    Open RutaZIP For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
    Set oApp = CreateObject("Shell.Application")
    oApp.Namespace(RutaZIP).CopyHere RutaArchivo
    On Error Resume Next
    Do Until oApp.Namespace(RutaZIP).items.Count = 1
        Application.Wait (Now + TimeValue("0:00:01"))
    Loop
    Set oApp = Nothing
    MsgBox "Archivo comprimido exitosamente", vbInformation, "Archivo Comprimido"
    Shell "C:\Windows\explorer.exe /select, " & RutaZIP, vbMaximizedFocus
 End Sub

Explanation:

Lo que se hace es verificar si el archivo a comprimir existe, crear un fichero (.zip) vacío y copiar el archivo dentro del fichero.

Ésta es una adaptación del código de Ron de Bruin.

Si te ha servido no olvides calificar. Buen viento y Buena mar.

gracias por la ayuda,

pero me tira error en la linea en negrita

en donde decia RutaArchivo yo coloque la ruta donde se guarda el archivo

If Dir("C:\Users\RON\Documents\listados\backup\") = "" Then
MsgBox "El archivo a comprimir no existe", vbCritical, "Ruta de archivo inválida"
Exit Sub
End If
RutaZIP = Left("C:\Users\RON\Documents\listados\backup\", InStrRev("C:\Users\RON\Documents\listados\backup\", ".") - 1) & Format(Now, "yyyy.mm.dd hh.mm") & ".zip"
If Dir(RutaZIP) <> "" Then Kill RutaZIP
Open RutaZIP For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(RutaZIP).CopyHere "C:\Users\RON\Documents\listados\backup\"
On Error Resume Next
Do Until oApp.Namespace(RutaZIP).items.Count = 1
Application.Wait (Now + TimeValue("0:00:01"))
Loop
Set oApp = Nothing
MsgBox "Archivo comprimido exitosamente", vbInformation, "Archivo Comprimido"
Shell "C:\Windows\explorer.exe /select, " & RutaZIP, vbMaximizedFocus

gracias

Mi recomendación es que copies este código, tal cual está, en un módulo del libro (añadí algunas mejoras).

 Sub ComprimirArchivo(ByVal RutaArchivo As String)
    'Ron de Bruin, Credits.
    Dim oApp As Object
    If Dir(RutaArchivo) = "" Then
        MsgBox "El archivo a comprimir no existe", vbCritical, "Ruta de archivo inválida"
        Exit Sub
    End If
    RutaZIP = Left(RutaArchivo, InStrRev(RutaArchivo, ".") - 1) & ".zip" 'call ComprimirArchivo (Ruta & "\" & nombre)
    If Dir(RutaZIP) <> "" Then Kill RutaZIP
    Open RutaZIP For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
    Set oApp = CreateObject("Shell.Application")
    Set oZip = oApp.Namespace(RutaZIP)
    If (Not oZip Is Nothing) Then
        oZip.CopyHere (RutaArchivo)
    End If
    'oApp.Namespace(RutaZIP).CopyHere RutaArchivo, glngcCopyHereDisplayProgressBox
    On Error Resume Next
    Do Until oZip.items.Count = 1
        Application.Wait (Now + TimeValue("0:00:01"))
        i = i + 1 ' Tempo de espera excedido
        If i = 8 Then MsgBox "No se ha podido comprimir el archivo": Exit Sub
    Loop
    Set oZip = Nothing
    Set oApp = Nothing
    MsgBox "Archivo comprimido exitosamente", vbInformation, "Archivo Comprimido"
    Shell "C:\Windows\explorer.exe /select, " & RutaZIP, vbMaximizedFocus
 End Sub

Y que el click de tu botón quede:

Private Sub commandbutton1_click()
Dim Ruta As String, nombre As String, Version As String
Application.StatusBar = "Guardando BACKUP..."
Ruta = "C:\Users\RON\Documents\listados\backup"
nombre = Left(ActiveWorkbook.Name, 17) + " " + Format(Now, "yyyy.mm.dd hh.mm") & " bp.xlsm"
Application.DisplayAlerts = False
Application.EnableEvents = False
ActiveWorkbook.Save
call ComprimirArchivo (Ruta & "\" & nombre)
Application.Quit
End Sub

Fíjate que en tu macro estoy llamando a mi procedimiento dándole el parámetro que te había mencionado antes "el path del archivo a comprimir (incluido el nombre del archivo)"

Ese path, por ejemplo, debe ser "D:\Costos Construcciones\Plegable_Curso_costos.pdf"

Por otra parte, aún no sé en qué momento guardas el archivo back up pero eso es otro asunto.

Si te ha servido no olvides calificar. Buen viento y Buena mar.

gracias amigo

funcionó

saludos