Attribute VB_Name = "PreparaBD"
Public rutaBuscarExcel As String
Public rutaDestino As String
Sub config()
rutaBuscarExcel = "C:\MD_Sql\OrigenExcel"
extensionBuscarExcel = "xls"
rutaDestino = "C:\MD_Sql\BDAuxiliar"
columnasProcesado = Array("DIRECTORIO", "NOMBRE")
limiteExcelProcesar = 50
End Sub
Sub BuscarArchivosXLS_origen(ByVal CarpetaInicial As String)
' Recorrer todos los archivos en la carpeta inicial
For Each Archivo In Carpeta.Files
' Verificar si el archivo tiene la extensi�n ".xls"
If InStr(LCase(Right(Archivo.Name, 5)), ".xls") <> 0 Then
' Hacer algo con el archivo (por ejemplo, imprimir el nombre)
Debug.Print Archivo.Path
End If
Next Archivo
For Each Subcarpeta In Carpeta.Subfolders
BuscarArchivosXLS Subcarpeta.Path
Next Subcarpeta
' Liberar el objeto FileSystemObject
Set FSO = Nothing
End Sub
Sub inicio()
Call config
Call BuscarArchivosXLS(rutaBuscarExcel, extensionBuscarExcel)
Close #1
End Sub
Function procesaCSV()
Dim nombreExcelListado
nombreExcelListado = Replace(hojaCSV.Cells(r + cont, c + 1).Value, "##", ",")
v = hojaCSV.Cells(r + cont, c).Value & "\" & nombreExcelListado
End Function
Sub ObtenerColumnaActiva()
Call config
For Each it In rng
Call procesaOneCSV(it.row)
Next
End Sub
Function procesaOneCSV(posPpal)
If (nombreExcelListado <> "") Then
If (hojaPpal.Cells(posPpal, cPos("link")).Value = "") Then
hojaPpal.Cells(posPpal, cPos("link")).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=nombreExcelListado, TextToDisplay:=nombreExcelListado
End If
If isFormatoExcelMD(nombreExcelListado) = False Then
'hojaPpal.Cells(posPpal, 2).Value = v
hojaPpal.Cells(posPpal, cPos("observacion")).Value = "Formato de archivo no reconocido, no se procesa"
Else
resultHoja = procesaExcelMedicion(nombreExcelListado)
If IsEmpty(resultHoja) Then
'hojaPpal.Cells(posPpal, 2).Value = v
hojaPpal.Cells(posPpal, cPos("observacion")).Value = "VACIO"
Else
lres = UBound(resultHoja)
'hojaPpal.Cells(posPpal, 2).Value = v
hojaPpal.Cells(posPpal, cPos("hoja")).Value = resultHoja(0)
If lres > 0 Then hojaPpal.Cells(posPpal, cPos("version")).Value = resultHoja(1)
If lres > 1 Then hojaPpal.Cells(posPpal, cPos("observacion")).Value = resultHoja(2)
End If
End If
End If
'MsgBox "Procesados " & contadorProcesados & " calculos de presupuestos MD."
End Function
Function isFormatoExcelMD(texto) As Boolean
Dim patron As String
Dim regEx As Object
Dim matches As Object
Dim match As Object
'patron = "OF\.MD\s\d{6}(\.\d)?-\w+,\s[\w\s]+\.xls"
patron = "OF\.MD \d+(\.\d+)?[-_\s](\w)+?[^,]+(\s*,\s*[^,]+)*\.xls"
Set regEx = CreateObject("VBScript.RegExp")
With regEx
.Pattern = patron
.Global = True
End With
Set matches = regEx.Execute(texto)
If matches.Count > 0 Then
'Set match = matches.Item(0)
'Debug.Print "OK " & match.Value
isFormatoExcelMD = True
Else
isFormatoExcelMD = False
End If
Debug.Print " isFormatoExcelMD=", isFormatoExcelMD
End Function
Function procesaExcelMedicion(RutaArchivo) As Variant
If (hojas(0) = "ERROR") Then
procesaExcelMedicion = Array(
"ERROR en nombre de pesta�a. Tomamos la primera hoja.", "", "")
MiLibro.Sheets(1).Select
resultSQL = SQL_export.SQL_export
Else
procesaExcelMedicion = Array("Encontrada hoja: " & hojas(1), "", "")
resultSQL = SQL_export.SQL_export
End If
Windows(nombreExcel).Activate
salida:
MiLibro.Close
cerrado:
procesaExcelMedicion = resultSQL
End Function
Function nombreHojas(excelAbierto) As Variant
Dim result As Variant
result = Array("", "", "")
Dim txt, n
Dim contMD
contMD = 0
txt = ""
With excelAbierto.Sheets
For i = 1 To .Count
result(2) = result(2) & ";" & n
Next i
End With
If (contMD = 0) Then
result(1) = "No se encuentra la hoja a procesar"
Else
result(1) = txt
result(2) = "ADVERTENCIA: " & result(2)
End If
nombreHojas = result
End Function
Function isProcessed(sheetXLS, nombreArchivo, Optional searchColumn = 1) As Variant
v = sheetXLS.Cells(cont, c).Value '& "\" & sheetXLS.Cells(cont, c + 1).Value
While (v <> "")
If (v = nombreArchivo) Then
isProcessed = Array(1, cont)
Exit Function
End If
v = sheetXLS.Cells(cont, c).Value
cont = cont + 1
Wend
isProcessed = Array(0, cont)
End Function
Function ObtenerTamanoArchivo(RutaArchivo As String) As Long
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FileExists(RutaArchivo) Then
ObtenerTamanoArchivo = fs.GetFile(RutaArchivo).Size
Else
ObtenerTamanoArchivo = -1 ' Devuelve -1 si el archivo no existe
End If
Set fs = Nothing
End Function
Function BuscarArchivosXLS(ByVal CarpetaInicial As String, extension)
Dim Carpeta As Object, Subcarpeta As Object
Dim Archivo As Object
Dim FSO As Object
Dim Ruta As String
' Crear un objeto FileSystemObject
Set FSO = CreateObject("Scripting.FileSystemObject")
' Comprobar si la carpeta inicial existe
If Not FSO.FolderExists(CarpetaInicial) Then
'MsgBox "La carpeta inicial no existe.", vbExclamation
Exit Function
End If
' Obtener la lista de archivos en la carpeta inicial
Set Carpeta = FSO.GetFolder(CarpetaInicial)
'Debug.Print "Buscando en " & CarpetaInicial
' Recorrer todos los archivos en la carpeta inicial
For Each Archivo In Carpeta.Files
' Verificar si el archivo tiene la extensi�n ".xls"
If InStr(LCase(Right(Archivo.Name, 5)), extension) <> 0 Then
' Hacer algo con el archivo (por ejemplo, imprimir el nombre)
Debug.Print Archivo.Path
Debug.Print Replace(CarpetaInicial & "\" & Archivo.Name, "\", "##")
'Print #1, Replace(ruta & "\" & archivo.Name, "\", "#")
Print #1, CarpetaInicial & "," & Replace(Archivo.Name, ",", "##") & "," & FSO.GetFile(Archivo.Path).Size
End If
Next Archivo
'Recorrer las subcarpetas de la carpeta inicial de forma recursiva
For Each Subcarpeta In Carpeta.Subfolders
Debug.Print Subcarpeta.Path
BuscarArchivosXLS Subcarpeta.Path, extension
Next Subcarpeta
' Liberar el objeto FileSystemObject
Set FSO = Nothing
End Function
Function Mostrar_Archivos(Ruta, extension)
Dim fs, Carpeta, Archivo, Subcarpeta As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Dim cont
cont = 0
If Ruta = "" Then
Exit Function
ElseIf Right(Ruta, 1) <> "" Then
Ruta = Ruta & ""
End If
On Error GoTo ErrHandler
Set Carpeta = fs.GetFolder(Ruta)
For Each Archivo In Carpeta.Files
'If InStr(LCase(Right(Archivo.Name, 5)), ".xls") <> 0 Then
If InStr(LCase(Right(Archivo.Name, 5)), extension) <> 0 Then
'If InStr(Left(fs.GetExtensionName(Archivo), 5), extension) > 0 Then
'ActiveCell.Value = ruta
'ActiveCell.Offset(0, 1).Value = archivo.Name
'ActiveCell.Offset(0, 2).Value = Replace(ruta & "\" & archivo.Name, "\", "##")
'ActiveCell.Offset(1, 0).Select
Debug.Print Replace(Ruta & "\" & Archivo.Name, "\", "##")
'Print #1, Replace(ruta & "\" & archivo.Name, "\", "#")
Print #1, Ruta & "," & Replace(Archivo.Name, ",", "##")
numFiles = numFiles + 1
' fs.CopyFile Source:=fs.GetFile(archivo), _
' Destination:=DestinationFolder & "\" & archivo.Name, Overwritefiles:=False
End If
Next
'Secci�n 5: Obtener subcarpetas del objeto Folder
For Each Subcarpeta In Carpeta.Subfolders
Debug.Print "Entramos en subcarpeta: " & Subcarpeta
Call Mostrar_Archivos(Subcarpeta, extension)
Next
'Secci�n 6: Auto-ajustar columnas y salir
ActiveCell.EntireColumn.AutoFit
salimos:
Exit Function
ErrHandler:
'ActiveCell.Value = "Ruta inexistente"
End Function
Function AbrirCSV(nombreArchivo) As Boolean
If Right(nombreArchivo, 4) <> ".xls" And _
Right(nombreArchivo, 5) <> ".xlsx" And _
Right(nombreArchivo, 4) <> ".csv" Then
AbrirCSV = False
Exit Function
End If
On Error GoTo ErrHandler
Workbooks.OpenText Filename:=nombreArchivo, DataType:=xlDelimited, Semicolon:=True, Comma:=False, Local:=False
AbrirCSV = True
Exit Function
ErrHandler:
AbrirCSV = False
End Function;