Results 1 to 1 of 1

Thread: Recursive folder search

  1. #1

    Thread Starter
    New Member
    Join Date
    Mar 2023
    Posts
    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
    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


    Code 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
    Last edited by Shaggy Hiker; Mar 28th, 2023 at 10:02 AM.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width