Copia de seguridad que cree carpeta y subcarpeta para guardar archivo

Te la macro

Sub Respaldo()
'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 = ThisWorkbook.Path
    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

NOTA: El archivo no puede tener en su nombre el caracter ":", por eso le puse un "_"

Dante amor, he probado tu código y funciona a la perfección. Necesitaría incluir las siguientes modificaciones, a saber:

Que la copia de seguridad no se guarde en la misma ruta que el original, que se guarde en otra ruta distinta, en red; y con extensión "xls"

Ejemplo: "\\NombrePc\Usuario\Copia de Seguridad\*...\**...\NombredelArchivo.xls"

*Aquí iría la carpeta "Año", creada con tu código.

**Y aquí la subcarpeta "Mes", creada por tu mismo código.

Y, por último, sería correcto este código a la hora de cerrar y guardar el Libro, o tu código se podría incluír directamente en el evento.

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
''Sub Respaldo()
RealizaCopia
End Sub

Muchísimas gracias