Option Explicit
Option Private Module
Option Base 1
'//By JuanC - Feb. 2014
'//-- Procedimiento general -- //
'Seleccionar carpeta
'Ingresar nombre del archivo para Resumen
'Buscar recursivamente los libros dentro de la carpeta seleccionada
'Crear nuevo libro para Resumen
'Procesar cada libro encontrado (abre libro y copia las celdas específicas desde el libro al Resumen)
'Guardar Resumen
Public g_bCancel As Boolean
Public g_sFileName As String
Private m_wbk As Workbook
Private m_ws As Worksheet
Private m_vRng As Variant
Private m_vRng2 As Variant
Private m_fil As Long
Private m_Pivot As Range
Private Const cMAX = 10 '//Cantidad de celdas a extraer de cada planilla...
Private m_sRoot As String
'//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub SeleccionarCarpeta()
m_sRoot = Browse("Seleccionar carpeta")
If m_sRoot <> "" Then
m_sRoot = m_sRoot & "\"
End If
End Sub
Private Sub Crear_resumen()
Dim n&, lTotal&, dlg As Variant
If m_sRoot <> "" Then
'//Diálogo para pedir nombre para guardar archivo de resumen...
dlg = Application.GetSaveAsFilename("", FileFilter:="Libros de Excel(*.xlsx), *.xlsx", Title:="Guardar resumen como...")
If dlg <> False Then
g_sFileName = dlg
Else
g_bCancel = True
Exit Sub
End If
g_bCancel = False
DoEvents
n = ScanFiles(m_sRoot, lTotal)
MsgBox "Proceso finalizado!" & vbCrLf & "Se procesaron " & n & " de " & lTotal & " libros.", vbInformation, "Información"
g_bCancel = True
Else
MsgBox "Por favor seleccione una carpeta.", vbExclamation, "Atención"
End If
End Sub
'//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Function ScanFiles(ByVal sRoot As String, ByRef n As Long) As Long
Dim sFolder$, sFileName$
Dim colDir As Collection, colFiles As Collection
Dim lCount&, i&, j&, lFilesCount&, tbl As Range
On Error Resume Next
'//Colecciones para carpetas y archivos...
Set colDir = New Collection
Set colFiles = New Collection
colDir.Add sRoot
lCount = 1
lFilesCount = 0
Do While lCount <= colDir.Count '//Escaneo recursivo de directorios...
sRoot = colDir(lCount)
sFolder = Dir(sRoot, vbDirectory + vbNormal)
Do While sFolder <> ""
If sFolder <> "." And sFolder <> ".." Then
If (GetAttr(sRoot & sFolder) And vbDirectory) = vbDirectory Then
colDir.Add sRoot & sFolder & "\"
Else
sFileName = VBA.LCase(sRoot & sFolder)
If VBA.Right(sFileName, 4) = ".xls" Or VBA.Right(sFileName, 5) = ".xlsm" Or VBA.Right(sFileName, 5) = ".xlsx" Then
colFiles.Add sFileName
End If
End If
End If
sFolder = Dir
Loop
lCount = lCount + 1
Loop
n = colFiles.Count '//Cantidad de archivos encontrados...
If n > 0 Then '//Si encontró archivos crea un libro para resumen...
Set m_wbk = Excel.Workbooks.Add
Set m_ws = m_wbk.Sheets.Add
Set m_Pivot = m_ws.Range("A1")
m_ws.Name = "resumen"
m_fil = 1 '//Offset vertical para guardar datos en resumen...
Application.DisplayAlerts = False
For i = m_wbk.Sheets.Count To 1 Step -1 '//Elimina hojas innecesarias...
If m_wbk.Sheets(i).Name <> "resumen" Then m_wbk.Sheets(i).Delete
Next
Application.DisplayAlerts = True
End If
'//1 2 3 4 5 6 7 8 9 10
m_vRng = Array(("H11"), ("A14"), ("B14"), ("C14"), ("C16"), ("G16"), ("C24"), ("E25"), ("B28"), ("F28")) '//Celdas que serán copiadas...
Application.ScreenUpdating = False
For i = 1 To colFiles.Count '//Procesa todos los archivos encontrados...
Call Process(colFiles.Item(i))
lFilesCount = lFilesCount + 1
If g_bCancel Then Exit For
DoEvents
Next
If Not m_wbk Is Nothing Then '//Guarda libro resumen...
m_wbk.SaveAs Filename:=g_sFileName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
m_wbk.Close
End If
fin:
Application.ScreenUpdating = True
ScanFiles = lFilesCount
End Function
Private Sub Process(ByVal sFileName As String)
Dim wbk As Workbook, ws1 As Worksheet, cell As Range
Dim i&
Dim vValues() As Variant
On Error Resume Next
Set wbk = Workbooks.Open(Filename:=sFileName) '//Abre archivo a procesar...
Set ws1 = wbk.Sheets("Hoja1") '//Hoja de planilla para extraer datos...
ReDim vValues(cMAX)
For i = 1 To cMAX
Set cell = ws1.Range(m_vRng(i)).MergeArea.Cells(1, 1) '//Carga datos de la plantilla...
vValues(i) = VBA.Trim(cell.Value)
Next
m_Pivot.Offset(m_fil).Resize(, UBound(vValues)).Value = vValues '//Copia datos en el resumen...
m_fil = m_fil + 1
wbk.Close SaveChanges:=False '//Cierra archivo sin cambios...
Set wbk = Nothing
Set ws1 = Nothing
Set cell = Nothing
Erase vValues
End Sub
Private Function Browse(ByVal sTitle As String, Optional sPathIni As Variant) As String
Dim objShell As Object, objBrowse As Object, objFolder As Object
Browse = ""
On Error Resume Next
Set objShell = CreateObject("Shell.Application")
Set objBrowse = objShell.BrowseForFolder(0, sTitle, 0, 0) 'sPathIni) 17=Mipc 0=desktop
Set objFolder = objBrowse.Self
If Not objFolder Is Nothing Then
Browse = objFolder.Path
End If
On Error GoTo 0
End Function