Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 03-28-2023, 03:37 AM
OFFICE365 OFFICE365 is offline Recursive folder search Windows 11 Recursive folder search Office 2016
Novice
Recursive folder search
 
Join Date: Mar 2023
Posts: 1
OFFICE365 is on a distinguished road
Post 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
Reply With Quote
Reply

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
start with search folder WimDC Outlook 0 05-21-2021 04:48 AM
Recursive folder search 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

Other Forums: Access Forums

All times are GMT -7. The time now is 04:38 AM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2024, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2024 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft