#1
|
|||
|
|||
Recursive folder search
Select the source folder, and search for matches with the excel 1 file.
The files that exist in excel 1 will be searched in the source folder and copied to the destination folder. I need help about one menu for selecting the source folder, because which one doesnt give the value to the main code... MAIN CODE Option Explicit ' Variables globales Public gCarpetaOrigen As String ' Función para mostrar un formulario que pide al usuario la carpeta de origen. Function MostrarFormulario() As Boolean Dim frm As New UserForm1 frm.Show vbModal ' Asignar la carpeta de origen que seleccionó el usuario. gCarpetaOrigen = frm.carpetaOrigen ' Comprobar que se ha seleccionado una carpeta de origen válida. If Len(gCarpetaOrigen) > 0 Then MostrarFormulario = True Else MostrarFormulario = False End If End Function ' Subrutina principal que copia los archivos de facturas. Sub CopiarArchivosFacturas() ' Mostrar el formulario para que el usuario seleccione la carpeta de origen. If Not MostrarFormulario Then Exit Sub ' Pedir al usuario que seleccione el archivo de Excel. Dim archivoExcel As Variant archivoExcel = Application.GetOpenFilename("Archivos de Excel (.xls;.xlsx), .xls;.xlsx") ' Comprobar que se ha seleccionado un archivo de Excel válido. If TypeName(archivoExcel) = "Boolean" Then Exit Sub ' Abrir el archivo de Excel seleccionado. Dim libroExcel As Workbook Set libroExcel = Workbooks.Open(archivoExcel) ' Buscar la celda que contiene la palabra "facturas". Dim hojaExcel As Worksheet Set hojaExcel = libroExcel.Sheets(1) Dim palabraFacturas As String palabraFacturas = "facturas" Dim rangoBusqueda As Range Set rangoBusqueda = hojaExcel.UsedRange Dim celdaFacturas As Range Set celdaFacturas = rangoBusqueda.Find(palabraFacturas) ' Comprobar que se ha encontrado la celda de facturas. If celdaFacturas Is Nothing Then MsgBox "No se ha encontrado la celda de facturas.", vbCritical, "Error" libroExcel.Close SaveChanges:=False Exit Sub End If ' Obtener la fila y columna de la celda de facturas. Dim filaFacturas As Long Dim columnaFacturas As Long filaFacturas = celdaFacturas.Row columnaFacturas = celdaFacturas.Column ' Obtener la carpeta de origen que seleccionó el usuario. Dim carpetaOrigen As String Select Case gCarpetaOrigen Case "MARTAINER" carpetaOrigen = "C:\MARTAINER" Case "PROGECO" carpetaOrigen = "C:\PROGECO" Case "BCNDEPOT" carpetaOrigen = "C:\BCNDEPOT" Case "TODOS" carpetaOrigen = "C:" Case Else MsgBox "La opción de carpeta de origen seleccionada no es válida.", vbCritical, "Error" libroExcel.Close SaveChanges:=False Exit Sub End Select ' Pedir al usuario que seleccione la carpeta de destino. Dim carpetaDestino As String Dim dialogoCarpetaDestino As Object Set dialogoCarpetaDestino = CreateObject("Shell.Application").Browse Set dialogoCarpetaDestino = CreateObject("Shell.Application").BrowseForFolder( 0, "Seleccione la carpeta de destino", 0, 0) ' Comprobar que se ha seleccionado una carpeta de destino válida. If dialogoCarpetaDestino Is Nothing Then MsgBox "Debe seleccionar una carpeta de destino.", vbCritical, "Error" libroExcel.Close SaveChanges:=False Exit Sub Else carpetaDestino = dialogoCarpetaDestino.Items.Item.Path & "" End If ' Copiar los archivos de facturas. Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Dim archivoFactura As Range Dim nombreArchivoFactura As String Dim i As Long For i = filaFacturas + 1 To hojaExcel.Cells(hojaExcel.Rows.Count, columnaFacturas).End(xlUp).Row Set archivoFactura = hojaExcel.Cells(i, columnaFacturas) nombreArchivoFactura = archivoFactura.Value ' Copiar el archivo de forma recursiva desde la carpeta de origen a la carpeta de destino. CopiarArchivoRecursivo carpetaOrigen, carpetaDestino, nombreArchivoFactura, fso Next i ' Cerrar el archivo de Excel. libroExcel.Close SaveChanges:=False MsgBox "Proceso finalizado.", vbInformation, "Operación completada" End Sub ' Subrutina que copia un archivo de forma recursiva desde una carpeta de origen a una carpeta de destino. Sub CopiarArchivoRecursivo(ByVal carpetaOrigen As String, ByVal carpetaDestino As String, ByVal nombreArchivo As String, ByRef fso As Object) ' Buscar el archivo en la carpeta de origen. Dim archivoEncontrado As Object Dim archivoCopiado As Boolean archivoCopiado = False For Each archivoEncontrado In fso.GetFolder(carpetaOrigen).Files If InStr(1, archivoEncontrado.Name, nombreArchivo, vbTextCompare) > 0 Then ' Generar un nuevo nombre de archivo si ya existe uno con el mismo nombre en la carpeta de destino. Dim nuevoNombreArchivo As String nuevoNombreArchivo = archivoEncontrado.Name Dim contador As Integer contador = 1 While fso.FileExists(carpetaDestino & nuevoNombreArchivo) nuevoNombreArchivo = fso.GetBaseName(archivoEncontrado.Name) & "(" & contador & ")." & fso.GetExtensionName(archivoEncontrado.Name) contador = contador + 1 Wend ' Copiar el archivo de origen a la carpeta de destino. fso.CopyFile archivoEncontrado.Path, carpetaDestino & nuevoNombreArchivo, True archivoCopiado = True End If Next archivoEncontrado ' Si el archivo no se ha encontrado en la carpeta de origen, buscarlo en las subcarpetas de forma recursiva. If Not archivoCopiado Then Dim subcarpeta As Object For Each subcarpeta In fso.GetFolder(carpetaOrigen).SubFolders CopiarArchivoRecursivo subcarpeta.Path, carpetaDestino, nombreArchivo, fso Next subcarpeta End If End Sub FORM CODE Option Explicit Private Sub ComboBox1_Change() End Sub Private Sub UserForm_Initialize() With Me.ComboBox1 .AddItem "MARTAINER" .AddItem "PROGECO" .AddItem "BCNDEPOT" .AddItem "TODOS" End With End Sub Private Sub CommandButton1_Click() If Me.ComboBox1.ListIndex < 0 Then MsgBox "Por favor, seleccione una opción de carpeta de origen.", vbCritical, "Error" Exit Sub End If ' CopiarArchivosFacturas (Eliminar esta línea) Unload Me End Sub Public Property Get carpetaOrigen() As String carpetaOrigen = ComboBox1.Value End Property Private Sub CommandButtonAceptar_Click() Me.Hide End Sub |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
start with search folder | WimDC | Outlook | 0 | 05-21-2021 04:48 AM |
Combobox recursive | il_betto | Word VBA | 13 | 06-04-2019 05:40 AM |
Use CSV as search criteria for Outlook search folder | lonesoac0 | Outlook | 0 | 03-07-2016 02:31 PM |
Recursive animation | Oscemc | PowerPoint | 0 | 01-22-2014 08:11 AM |
Search Folder sent to criteria | markstro | Outlook | 0 | 12-20-2011 02:47 PM |