Macro que copia archivos entre carpetas e indique resultado.
Tengo una macro que busca archivos con cierto nombre especificado y los pega en una ruta especifica.
Actualmente funciona bien, pero cuando el archivo indicado no se encuentra (no copia y pega), la idea es que en la columna ("G:G") me indique cuantos archivos copia de esa carpeta. Me explico: en la Columna ("A:A") estan unos números de carpeta, en las columnas ("B:E") están los nombres de los archivos "Estos nombres están formulados ya que mantienen un mismo formato", en la columna ("F:F") esta la ruta de destino donde debe guardar los cuatro documentos, pero en ocasiones no trae los cuatro, la idea es que en la columna ("G:G") me indique cuantos archivos copia de esa carpeta. Ejemplo: 1 de 4, 2 de 4, 3 de 4, o 4 de 4. La carpeta de origen donde están los archivos esta dentro del código.
El código actual es este:
Sub Copiar_Archivos_JC() 'John Cárdenas. Hoja1.Select Dim Name_Files As Range, xCell As Range Dim xSFileDlg As FileDialog, xDFileDlg As FileDialog Dim Carpeta_Origen As Variant, Carpeta_Destino As Variant Dim xVal As String ult_ren = Application.WorksheetFunction.CountA(Range("A:A")) If ult_ren <= 1 Then MsgBox "No se puede continuar no existen carpetas a buscar", 16, "John Cárdenas" Exit Sub Else Range("Cedula").Select Columna_Inicial = ActiveCell.Column Columna_Final = Columna_Inicial + 3 Dim i As Long For i = 2 To ult_ren For i2 = Columna_Inicial To Columna_Final 'indicador de columnas On Error Resume Next Set Name_Files = Cells(i, i2) If Name_Files Is Nothing Then Exit Sub Carpeta_Origen = "C:\f\Carpeta1\" & Cells(i, 1) & "\2.DOCUMENTOS_FASE 2\" Carpeta_Destino = Cells(i, Columna_Final + 1) For Each xCell In Name_Files xVal = xCell.Value If TypeName(xVal) = "String" And xVal <> "" Then FileCopy Carpeta_Origen & xVal, Carpeta_Destino & xVal End If Next Next Next Range("A1").Select End If End Sub
La base de datos que tengo o la hoja1 es esta:
