Copiar múltiples archivos a carpetas con nombre similar
Antes de nada alabar su excelente trabajo y dedicación en ayudar a las personas.
Mi consulta casi la tiene resuelta en un post del año 2012, 29 de septiembre (Copia muchos archivos a variadas carpetas según el nombre del archivo a copia y carpeta destino), pero no consigo acoplarla.
Necesito que en una carpeta local de un PC, donde tengo multitud de ficheros con los siguientes nombres:
654321(1), 654321(2), 564321(1), 564321(2), 564332(1), 564332(2), 564332(3) (*)
(*)El numero de ficheros entre paréntesis es variable. Pueden ser pdf y jpg.
Moverlos a otra unidad donde existen las carpetas, pero sin el indice
654321 --> a esta carpeta moveríamos 654321(1) y 654321(2)
564321 --> a esta carpeta moveríamos 564321(1) y 654321(2)
564332 --> a esta carpeta moveríamos 564332 (1), 564332 (2) y 564332(3)
Te anexo una nueva macro. En la carpeta_origen, debes poner todos tus archivos.
En la carpeta_destino deberán estar tus distintas carpetas, por ejemplo, deberás tener algo como esto:
C:\Trabajo\archivos\564321
C:\Trabajo\archivos\564332
Cambia en la macro
carpeta_origen = "C:\trabajo\general\"
carpeta_destino = "c:\trabajo\archivos\"
Por los nombres de tus carpetas.
También debes tener una hoja llamada "Hoja1" para poner el resultado de la copia.
Sub Copiar_Archivos_A_Carpetas()
'Por.Dante Amor
Set h1 = Sheets("Hoja1")
h1.Cells.ClearContents
'
carpeta_origen = "C:\trabajo\general\"
carpeta_destino = "c:\trabajo\archivos\"
'
i = 2
arch = Dir(carpeta_origen & "*.*")
Do While arch <> ""
p = InStrRev(arch, ".")
h1.Cells(i, "A") = Mid(arch, 1, p - 1)
h1.Cells(i, "B") = Mid(arch, p)
i = i + 1
arch = Dir()
Loop
u = Range("A" & Rows.Count).End(xlUp).Row
Range("A2:A" & u).TextToColumns Destination:=Range("C2"), _
DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, _
Space:=False, Other:=True, _
OtherChar:="(", FieldInfo:=Array(Array(1, 2), Array(2, 2)), _
TrailingMinusNumbers:=True
'
For i = 2 To u
carpeta = WorksheetFunction.Trim(Cells(i, "C")) & "\"
archivo = Cells(i, "A") & Cells(i, "B")
If Dir(carpeta_destino & carpeta, vbDirectory) <> "" Then
FileCopy carpeta_origen & archivo, carpeta_destino & carpeta & archivo
Cells(i, "E") = "Archivo copiado"
Else
Cells(i, "E") = "No existe la carpeta"
End If
Next
'
MsgBox "Fin"
End Sub.
.
