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.