Ampliación a copia de seguridad que cree carpeta y subcarpeta para guardar archivo

Cambia en la macro esta línea

ruta = ThisWorkbook.Path

Por esta

ruta = "\\NombrePc\Usuario\Copia de Seguridad"

Prueba y me comentas

Puedes poner todo el código en el evento.

Gracias, de nuevo, Dante Amor. Si ejecuto la macro directamente, funciona; ahora bien, si incluyo el código dentro del evento, curiosamente crea las carpetas, pero no guarda ni los cambios efectuados en el archivo original ni realiza el backup. Así integro tu código en el evento:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'Por.Dante Amor
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    ThisWorkbook.Save
    nom1 = ThisWorkbook.FullName
    nom2 = ThisWorkbook.Name
    meses = Array("", "enero", "febrero", "marzo", "abril", "mayo", "junio", "julio", _
              "agosto", "septiembre", "octubre", "noviembre", "diciembre")
    mes = meses(Month(Date))
    '
    ruta = "\\NombrePc\Usuario\Copia de Seguridad"
    ruta1 = ruta & "\" & Year(Date)
    ruta2 = ruta1 & "\" & mes
    If Dir(ruta1, vbDirectory) = "" Then
        MkDir ruta1
    End If
    If Dir(ruta2, vbDirectory) = "" Then
        MkDir ruta2
    End If
    '
    fecha = Year(Date) & "_" & Month(Date) & "_" & Day(Date)
    hora = Hour(Time) & "_" & Minute(Time) & "h"
    nom2 = Left(nom2, InStrRev(nom2, ".") - 1)
    '
    Archivo = "Backup_" & nom2 & " " & fecha & " " & hora
    ActiveWorkbook.SaveAs _
        Filename:=ruta2 & "\" & Archivo, _
        FileFormat:=xlOpenXMLWorkbookMacroEnabled, _
        CreateBackup:=True
    '
    Set Nuevo = ThisWorkbook
    Workbooks.Open nom1
    Nuevo.Close
End Sub

Perdona, peo ignoro cual puede ser el problema. También ocurre al ejecutar la macro directamente, que el archivo lo guarda en formato "xlsm". Estoy probando en código en Excel 2007; aunque lo necesito para trabajar en Excel 2003.

Saludos

El cambio que solicitaste está bien.

Ahora lo que estás haciendo en el evento beforesave es guardar el archivo y luego vuelves a guardar el archivo. Entonces la macro que estaba en ejecución continúa en el primer archivo guardado.

En pocas palabras estás haciendo un ciclo de guardar archivos. No entiendo por qué vas a crear una copia de seguridad en el momento en que estás guardando el archivo.

Guarda el archivo y en otro evento o con la macro respaldo realiza el guardado.

Para la versión 2003 hay que cambiar la forma de guardado.

Gracias por tu paciencia. Estoy un poco perdido. ¿cómo ejecuto tu código y, posteriormente, se guarde el archivo original con los cambios efectuados en el mismo? Insisto, tengo que hacerlo para la versión 2003. Por favor, dentro de qué evento debo hacerlo.

Saludos.

Esta versión de macro es para la 2007

Debes cambiar esto para la versión 2003

ActiveWorkbook.SaveAs _
        Filename:=ruta2 & "\" & Archivo, _
        FileFormat:=xlOpenXMLWorkbookMacroEnabled, _
        CreateBackup:=True

Lo que estás haciendo es guardar 2 veces

Cambia la macro al evento beforeclose, prueba y me comentas

Tal como me dices, entiendo que debería quedar así, para Excel 2003:

Private Sub Workbook_BeforeClose(Cancel As Boolean)
'Por.Dante Amor
    Application.ScreenUpdating = False
    Application.DisplayAlerts = True
    ThisWorkbook.Save
    nom1 = ThisWorkbook.FullName
    nom2 = ThisWorkbook.Name
    meses = Array("", "enero", "febrero", "marzo", "abril", "mayo", "junio", "julio", _
              "agosto", "septiembre", "octubre", "noviembre", "diciembre")
    mes = meses(Month(Date))
    '
    ruta = "C:\Adri\Adri\Copia de Seguridad"
    ruta1 = ruta & "\" & Year(Date)
    ruta2 = ruta1 & "\" & mes
    If Dir(ruta1, vbDirectory) = "" Then
        MkDir ruta1
    End If
    If Dir(ruta2, vbDirectory) = "" Then
        MkDir ruta2
    End If
    '
    fecha = Year(Date) & "_" & Month(Date) & "_" & Day(Date)
    hora = Hour(Time) & "_" & Minute(Time) & "h"
    nom2 = Left(nom2, InStrRev(nom2, ".") - 1)
    '
    Archivo = "Backup_" & nom2 & " " & fecha & " " & hora
    'ActiveWorkbook.SaveAs _
        'Filename:=ruta2 & "\" & Archivo, _
        'FileFormat:=xlOpenXMLWorkbookMacroEnabled, _
        'CreateBackup:=True
     ActiveWorkbook.SaveAs _
        Filename:=ruta2 & "\" & Archivo, _
        FileFormat:=xlOpenXMLWorkbookMacroEnabled, _
        CreateBackup:=True
    '
    Set Nuevo = ThisWorkbook
    Workbooks.Open nom1
    Nuevo.Close
End Sub

Pero para 2003 tienes que quitar esto

ActiveWorkbook.SaveAs _
        Filename:=ruta2 & "\" & Archivo, _
        FileFormat:=xlOpenXMLWorkbookMacroEnabled, _
        CreateBackup:=¿True

Quieres guardar el archivo para versión 2003 o estás trabajando con excel 2003?

Si lo vas a guardar para la versión 2003 es con esto

Filename:=ruta2 & "\" & Archivo, FileFormat:=xlExcel8

Entiendo que suprimiendo esas líneas de código es para cuando se trabaja con excel 2003 (como es mi caso). Y si se utiliza 2007, únicamente habría que cambiar solo esa línea de código para que el libro se guarde en la versión de 2003. ¿Es así?

No se como agradecerte tu tiempo.

Saludos