Copia muchos archivos a variadas carpetas según el nombre del archivo a copia y carpeta destino
Hola
Yo, de nuevo
Te cuento que funciona bien la macro solo en disco raíz C:\
cuando configuro las carpetas destino en disco E:\ no copia( lo estoy probando en computador de mi casa que tiene dos discos), antes de probarlo con disco de red en mi trabajo . Ademas el reporte que genera en excel la segunda columna se desplaza hacia abajo (no queda linea con los otros datos)
1 Respuesta
Te preguntaba si podías copiar de C: a E: desde windows, o tienes que hacer algo.
Por otra parte, la columna A tiene archivos y la columna B tiene carpetas, no necesariamente son iguales, sólo las puse para realizar las búsquedas, es probable que se acoplen si eliminamos las 2 primeras carpetas: "." que significa la carpeta actual y ".." que significa la carpeta anterior, pero como te expliqué solamente las utilizo para realizar la búsqueda.
Si quieres que no las ponga, cambia el código
Do While carpe <> ""
ActiveCell.Value = carpe
ActiveCell.Offset(1, 0).Select
carpe = Dir()
Loop
Por este código
Do While carpe <> ""
If carpe <> "." And carpe <> ".." Then
ActiveCell.Value = carpe
ActiveCell.Offset(1, 0).Select
End If
carpe = Dir()
Loop
Saludos. Dam
Copia con Error 76
C:\Pendientes\3417 -aaaa.pdf
E:\equipos\3417 -aaaa.pdf\3417 -aaaa.pdf
intentó copiar en carpeta E:\equipos y no en carpeta E:\equipos\3417 -aaaa
Si te refieres a copiar un archivo desde C: a E: , si se puede sin problema
Te mando toda la macro, funciona para diferentes drives C: D: E: etc.
'*******Macro******
Sub listar_archivos()
'Por.Dam
'Lee archivos de un directorio y los copia en un destino
On Error Resume Next
Dim archori, archdes As String
'carpetaorigen = "C:\Documents and Settings\DAMOR\Mis documentos\docs\Soporte expertos\archivos\"
'carpetadestino = "E:\equipos\"
carpetaorigen = "C:\Pendientes\"
carpetadestino = "E:\equipos\"
'lee archivos del origen
ChDrive Left(carpetaorigen, 1)
ChDir carpetaorigen
archi = Dir("*.*")
Workbooks("copiaarchivos").Activate
Range("A:E").Clear
Range("A1").Select
Do While archi <> ""
ActiveCell.Value = archi
ActiveCell.Offset(1, 0).Select
archi = Dir()
Loop
'lee las carpetas destino
ChDrive Left(carpetadestino, 1)
ChDir carpetadestino
carpe = Dir("*", vbDirectory)
Range("B1").Select
Do While carpe <> ""
If carpe <> "." And carpe <> ".." Then
ActiveCell.Value = carpe
ActiveCell.Offset(1, 0).Select
End If
carpe = Dir()
Loop
ufila = Range("A" & Rows.Count).End(xlUp).Row
ufilacarpetas = Range("B" & 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
escuatro = InStr(1, celda, "-")
If escuatro = 5 Then
numarchivo = Left(Cells(lin, 1).Value, 4)
Else
If escuatro = 6 Then
numarchivo = Left(Cells(lin, 1).Value, 5)
End If
End If
'busca numero archivo en el numero de carpeta
lincarpetas = 1
nomcarpeta = ""
Do While lincarpetas <= ufilacarpetas
If escuatro = 5 Then
nummasguion = numarchivo & "-"
If nummasguion = Left(Cells(lincarpetas, 2).Value, 5) Then
nomcarpeta = Cells(lincarpetas, 2).Value
Exit Do
End If
Else
If escuatro = 6 Then
'numarchivo = Left(Cells(lin, 1).Value, 5)
nummasguion = numarchivo & "-"
If nummasguion = Left(Cells(lincarpetas, 2).Value, 6) Then
nomcarpeta = Cells(lincarpetas, 2).Value
Exit Do
End If
End If
End If
lincarpetas = lincarpetas + 1
nomcarpeta = ""
Loop
If nomcarpeta = "" Then
'La carpeta destino no existe
Cells(lin, 3).Value = ("La carpeta destino no existe")
Cells(lin, 4).Value = archori
Cells(lin, 5).Value = archdes
Else
archdes = carpetadestino & nomcarpeta & "\" & Cells(lin, 1).Value
FileCopy archori, archdes
If Err.Number = 0 Then
'El archivo fue copiado
Cells(lin, 3).Value = ("Copiado")
Else
Cells(lin, 3).Value = ("Copia con Error " & Err.Number)
Err.Number = 0
Cells(lin, 4).Value = archori
Cells(lin, 5).Value = archdes
End If
End If
lin = lin + 1
Loop
End Sub
'******Macro*******Saludos.dam
