Code main :
VBA 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 SubCode Form
VBA 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 a moderator:
