Copiar una carpeta a varias carpetas de destino

Copia muchos archivos a variadas carpetas según el nombre del archivo a copia y carpeta destino, me sirvió mucho. Pero ahora estoy tratando de modificar esto:

'*******Macro******
Sub listar_archivos()
'Por.Dam
'Lee archivos de un directorio y los copia en un destino
On Error Resume Next
carpetaorigen = "C:\Pendientes\"
carpetadestino = "k:\\transfer\equipos\"
Set navegador = CreateObject("shell.application")
ChDir carpetaorigen
archi = Dir("*.*")
Workbooks("copiaarchivos").Activate
Range("A:D").Clear
Range("A1").Select
Do While archi <> ""
    ActiveCell.Value = archi
    ActiveCell.Offset(1, 0).Select
    ActiveCell.Value = celda
    archi = Dir()
Loop
Dim archori, archdes As String
ufila = Range("A" & Rows.Count).End(xlUp).Row
Range("A1").Select
lin = 1
Do While lin <= ufila
    archori = carpetaorigen & Cells(lin, 1).Value
    celda = Cells(lin, 1).Value
    caracter = InStr(7, celda, "-")
    numcarpeta = Left(Cells(lin, 1).Value, caracter - 1)
    archdes = carpetadestino & numcarpeta & "\" & Cells(lin, 1).Value
    FileCopy archori, archdes
    If Err.Number = 0 Then
        'El archivo fue copiado
        Cells(lin, 2).Value = ("Copiado")
    Else
        Cells(lin, 2).Value = ("Copia con Error " & Err.Number)
        Err.Number = 0
        Cells(lin, 3).Value = archori
        Cells(lin, 4).Value = archdes
    End If
    lin = lin + 1
Loop
End Sub
'******Macro*******

Pero solo necesito por favor y es lo siguiente: tengo esta carpeta llamada ANOTACIONES, necesito copiarla a las subcarpetas  de la carpeta de destino llamada Facturas, estas subcarpetas serian estas: 1078624, 1078626, 1078629, cada una de estas subcarpetas representan una factura.

Seria tan amable de colaborarme.