i have a problem with a button select, because when i am going to do the buttons in order to join the macro, it gives me an error . Attached the code in vba :
Option Explicit
Sub CopiarArchivosFacturas()
' 1. Abrir un archivo de Excel determinado por el usuario
Dim archivo As Variant
archivo = Application.GetOpenFilename("Archivos de Excel (*.xls*;*.xlsx), *.xls*;*.xlsx")
If TypeName(archivo) = "Boolean" Then Exit Sub ' Si el usuario cancela la selección
Dim wb As Workbook
Set wb = Workbooks.Open(archivo)
' 2. Buscar la palabra "facturas" en la hoja de Excel
Dim hoja As Worksheet
Set hoja = wb.Sheets(1)
Dim palabra As String
palabra = "Invoice Number"
' 3. Localizar e indicar en qué columna y fila se encuentra esa palabra "facturas"
Dim rangoBusqueda As Range
Set rangoBusqueda = hoja.UsedRange
Dim celda As Range
Set celda = rangoBusqueda.Find(palabra)
Dim FIL As Long
Dim COL As Long
FIL = celda.Row
COL = celda.Column
Here the form must to be :
[highlight #CC0000]Dim rutaOrigen As String
rutaOrigen = "D:\Donnees\Invoice\REPAIR_INVOICE\"[/highlight]
Dim rutaDestino As String
rutaDestino = "C:\destino\"
' 6. Copiar todos los archivos encontrados debajo de la celda facturas y que coincidan con los archivos que hay en tanto carpetas como subcarpetas en el directorio origen
Dim archivoFactura As Range
Dim i As Long
For i = FIL + 1 To hoja.Cells(hoja.Rows.Count, COL).End(xlUp).Row
Set archivoFactura = hoja.Cells(i, COL)
Dim nombreArchivoFactura As String
nombreArchivoFactura = archivoFactura.Value
CopiarArchivoRecursivo rutaOrigen, rutaDestino, nombreArchivoFactura
Next i
' Cerrar el archivo de Excel
wb.Close SaveChanges:=False
MsgBox "Proceso finalizado", vbInformation, "Operación completada"
End Sub
Sub CopiarArchivoRecursivo(ByVal rutaOrigen As String, ByVal rutaDestino As String, ByVal nombreArchivoFactura As String)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim archivoEncontrado As Object
Dim archivoCopiado As Boolean
archivoCopiado = False
For Each archivoEncontrado In fso.GetFolder(rutaOrigen).Files
If InStr(1, archivoEncontrado.Name, nombreArchivoFactura, vbTextCompare) > 0 Then
Dim newFileName As String
newFileName = archivoEncontrado.Name
Dim counter As Integer
counter = 1
While fso.FileExists(rutaDestino & newFileName)
newFileName = fso.GetBaseName(archivoEncontrado.Name) & "(" & counter & ")." & fso.GetExtensionName(archivoEncontrado.Name)
counter = counter + 1
Wend
fso.CopyFile archivoEncontrado.Path, rutaDestino & newFileName, True
archivoCopiado = True
End If
Next archivoEncontrado
If Not archivoCopiado Then
Dim carpeta As Object
For Each carpeta In fso.GetFolder(rutaOrigen).SubFolders
CopiarArchivoRecursivo carpeta.Path, rutaDestino, nombreArchivoFactura
Next carpeta
End If
End Sub
-------------------------------------------------------------------------------------------------------------
[pre]I need to do some form ,because is te unique form in order to select for the guest[/pre]
Option Explicit
Sub CopiarArchivosFacturas()
' 1. Abrir un archivo de Excel determinado por el usuario
Dim archivo As Variant
archivo = Application.GetOpenFilename("Archivos de Excel (*.xls*;*.xlsx), *.xls*;*.xlsx")
If TypeName(archivo) = "Boolean" Then Exit Sub ' Si el usuario cancela la selección
Dim wb As Workbook
Set wb = Workbooks.Open(archivo)
' 2. Buscar la palabra "facturas" en la hoja de Excel
Dim hoja As Worksheet
Set hoja = wb.Sheets(1)
Dim palabra As String
palabra = "Invoice Number"
' 3. Localizar e indicar en qué columna y fila se encuentra esa palabra "facturas"
Dim rangoBusqueda As Range
Set rangoBusqueda = hoja.UsedRange
Dim celda As Range
Set celda = rangoBusqueda.Find(palabra)
Dim FIL As Long
Dim COL As Long
FIL = celda.Row
COL = celda.Column
Here the form must to be :
[highlight #CC0000]Dim rutaOrigen As String
rutaOrigen = "D:\Donnees\Invoice\REPAIR_INVOICE\"[/highlight]
Dim rutaDestino As String
rutaDestino = "C:\destino\"
' 6. Copiar todos los archivos encontrados debajo de la celda facturas y que coincidan con los archivos que hay en tanto carpetas como subcarpetas en el directorio origen
Dim archivoFactura As Range
Dim i As Long
For i = FIL + 1 To hoja.Cells(hoja.Rows.Count, COL).End(xlUp).Row
Set archivoFactura = hoja.Cells(i, COL)
Dim nombreArchivoFactura As String
nombreArchivoFactura = archivoFactura.Value
CopiarArchivoRecursivo rutaOrigen, rutaDestino, nombreArchivoFactura
Next i
' Cerrar el archivo de Excel
wb.Close SaveChanges:=False
MsgBox "Proceso finalizado", vbInformation, "Operación completada"
End Sub
Sub CopiarArchivoRecursivo(ByVal rutaOrigen As String, ByVal rutaDestino As String, ByVal nombreArchivoFactura As String)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim archivoEncontrado As Object
Dim archivoCopiado As Boolean
archivoCopiado = False
For Each archivoEncontrado In fso.GetFolder(rutaOrigen).Files
If InStr(1, archivoEncontrado.Name, nombreArchivoFactura, vbTextCompare) > 0 Then
Dim newFileName As String
newFileName = archivoEncontrado.Name
Dim counter As Integer
counter = 1
While fso.FileExists(rutaDestino & newFileName)
newFileName = fso.GetBaseName(archivoEncontrado.Name) & "(" & counter & ")." & fso.GetExtensionName(archivoEncontrado.Name)
counter = counter + 1
Wend
fso.CopyFile archivoEncontrado.Path, rutaDestino & newFileName, True
archivoCopiado = True
End If
Next archivoEncontrado
If Not archivoCopiado Then
Dim carpeta As Object
For Each carpeta In fso.GetFolder(rutaOrigen).SubFolders
CopiarArchivoRecursivo carpeta.Path, rutaDestino, nombreArchivoFactura
Next carpeta
End If
End Sub
-------------------------------------------------------------------------------------------------------------
[pre]I need to do some form ,because is te unique form in order to select for the guest[/pre]