Macro copiar varios archivos de una vez

[ToniTF81]

Buenas, necesito una macro que me permita abrir un cuadro de dialogo, seleccionar una carpeta y copiar todos los archivos que hay dentro a otro destino.

 

Gracias de antemano

Saludos!

[isidrod]

checa esto @ToniTF81

https://www.extendoffice.com/es/documents/excel/4775-move-files-based-on-excel-list.html

https://formulasexcel.com/listar-archivos-de-una-carpeta-con-macros-excel/

a ver si te funciona

saludos  isidro

[isidrod]

ahí va otro

 https://www.todoexpertos.com/categorias/tecnologia-e-internet/software-y-aplicaciones/microsoft-excel/respuestas/wj5umn35syfno/pasar-archivos-de-una-carpeta-a-otra-con-macro

[ToniTF81]

Hola @isidrod, muchas gracias por tu ayuda. A ver si me echas una mano a perfilarlo:

Function MiRuta()
    Dim directorio As String

    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Seleccionar Carpeta"
        .Show
        directorio = .SelectedItems(1)
    End With

    If directorio <> "" Then
        MiRuta = directorio
    End If
End Function
Sub ListArchivos()
    Dim ruta, archivos As String
    Dim i As Integer
   
    ruta = MiRuta
   
    archivos = dir(ruta & "\*.csv*")
   
    Worksheets("BD").Range("A2:A" & Worksheets("BD").Cells(Rows.Count, 1).End(xlUp).Row) = ""
    i = 2
    Do While Len(archivos) > 0
        Worksheets("BD").Cells(i, 1) = archivos
        archivos = dir()
        i = i + 1
        Loop
End Sub

Sub copiar()

Range("A2:A10").Select
On Error Resume Next
Do While ActiveCell.Value <> ""
    inicio = MiRuta & ActiveCell.Value
    fin = "Z:\destino\" & ActiveCell.Value
    valida = dir(inicio)
    If valida = "" Then
    ActiveCell.Offset(0, 1) = "Archivo no encontrado"
    Else
        FileCopy inicio, fin
    End If
    ActiveCell.Offset(1, 0).Select
Loop
End Sub

Funciona todo bien hasta que pretendí que inicio no fuera una ruta fija, ya que cambia todos los días, sino aprovechar que a se había establecido la ruta en la primera macro y la cogiera como inicio. Pero me devuelve "archivo no encontrado" en las celdas.

Como lo soluciono??

 

Gracias miles

[isidrod]

'https://www.todoexpertos.com/categorias/tecnologia-e-internet/software-y-aplicaciones/microsoft-excel/respuestas/wj5umn35syfno/pasar-archivos-de-una-carpeta-a-otra-con-macroSub copiar()
Sub copiar()
'Por.DAM
Range("B2").Select
On Error Resume Next
Do While ActiveCell.Value <> ""
    'inicio = "C:\Users\avabta\Documents\" & ActiveCell.Value
    'fin = "C:\cfdi\" & ActiveCell.Value
   inicio = Range("A2") & ActiveCell.Value
    fin = Range("D2") & ActiveCell.Value
   
   
  ' Carpeta = Range("Z2")
'Archivo = Range("Z3")
    
    valida = Dir(inicio)
    If valida = "" Then
        ActiveCell.Offset(0, 1) = "Archivo no encontrado"
    Else
        FileCopy inicio, fin
    End If
    ActiveCell.Offset(1, 0).Select
Loop
End Sub

a ver si así te funciona  te envió el archivo

COPIAR ARCHIVO DE UNA CARPETA A OTRA encelda.xlsm