Option Explicit
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Const SHEET_NAME_1 As String = "Sheet1"
Const SHEET_NAME_2 As String = "Sheet2"
Const SHEET_NAME_3 As String = "Sheet3"
Const SHEET_NAME_4 As String = "Sheet4"
Const SHEET_NAME_5 As String = "Sheet5"
Const SHEET_NAME_6 As String = "Sheet6"
Const SHEET_NAME_7 As String = "Sheet7"
Const SHEET_NAME_8 As String = "Sheet8"
Const MAX_PATH = 260
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
'
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Function CleanTrim(ByVal Text As String) As String
CleanTrim = WorksheetFunction.Trim(WorksheetFunction.Clean(Text))
End Function
Sub CollectData()
' This code assumes it is running in the worksheet code itself (Me should be a reference to
' the worksheet which the data is being consolidated into).
' ---------------------------------------------------------------------------------------------
Dim i As Long, lCurrRow As Long, lRow As Long, n As Long
Dim wb As Workbook, ans As VbMsgBoxResult
Dim hInstance As Long, wFile As WIN32_FIND_DATA, Filename As String
Dim SheetName As String, RowOffset As Long, ColumnCount As Long
Dim Sheet As Worksheet, FolderPath As String
Dim FolderPicker As FileDialog
' ---------------------------------------------------------------------------------------------
' Prompt user for folder path for the workbooks.
' ---------------------------------------------------------------------------------------------
Set FolderPicker = Application.FileDialog(msoFileDialogFolderPicker)
FolderPicker.AllowMultiSelect = False
FolderPicker.Title = "Select Workbook Folder"
FolderPicker.Show
If FolderPicker.SelectedItems.Count > 0 Then FolderPath = FolderPicker.SelectedItems(1)
' ---------------------------------------------------------------------------------------------
' Ensure we have a valid folder
' ---------------------------------------------------------------------------------------------
If VBA.FileSystem.Dir(FolderPath, vbDirectory) = "." Then Exit Sub
' ---------------------------------------------------------------------------------------------
'
' ---------------------------------------------------------------------------------------------
hInstance = FindFirstFile(FolderPath & "\*.xls*", wFile)
Do
Filename = CleanTrim(wFile.cFileName)
' ---------------------------------------------------------------------------------------------
' Ensure we are only grabing other files (skip this one)
' ---------------------------------------------------------------------------------------------
If Filename = ThisWorkbook.Name Then GoTo SkipFile
' ---------------------------------------------------------------------------------------------
' Ensure we are skipping any temp files generated due to a file being open
' ---------------------------------------------------------------------------------------------
If Strings.Left(Filename, 1) = "~" Then GoTo SkipFile
' ---------------------------------------------------------------------------------------------
' Open up Source Workbook
' ---------------------------------------------------------------------------------------------
On Error Resume Next
WriteTimeStampedEntry "Starting to open file " & Filename
Set wb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & Filename)
If Not Err.Number = 0 Then
Err.Clear
' ---------------------------------------------------------------------------------------------
' No source workbook found, advise user.
' ---------------------------------------------------------------------------------------------
ans = MsgBox("Could not find Source " & Filename & " Workbook." & _
vbNewLine & "Do you wish to continue?", vbInformation + vbYesNo, "Error")
WriteTimeStampedEntry "Error occured opening " & Filename
If ans = vbNo Then Exit Sub
GoTo NextI
End If
WriteTimeStampedEntry "Finished opening " & Filename
' ---------------------------------------------------------------------------------------------
' Cycle through our expected tabs
' ---------------------------------------------------------------------------------------------
For i = 1 To 8 Step 1
' ---------------------------------------------------------------------------------------------
' Source book was found, data to use is on SheetName.
' ---------------------------------------------------------------------------------------------
SheetName = GetSheetName(i)
With wb.Sheets(SheetName)
If Not Err.Number = 0 Then
Err.Clear
' ---------------------------------------------------------------------------------------------
' No SheetName tab found, look for next one.
' ---------------------------------------------------------------------------------------------
GoTo NextSheet
End If
' ---------------------------------------------------------------------------------------------
' Setup our own master sheet
' ---------------------------------------------------------------------------------------------
Set Sheet = ThisWorkbook.Sheets(SheetName)
If Not Err.Number = 0 Then
' ---------------------------------------------------------------------------------------------
' We don't have a master copy of this sheet, create one.
' ---------------------------------------------------------------------------------------------
Set Sheet = ThisWorkbook.Sheets.Add
Sheet.Name = SheetName
' ---------------------------------------------------------------------------------------------
' Transfer Headers, if we don't already have them
' ---------------------------------------------------------------------------------------------
ColumnCount = 1
Do Until .Cells(1, ColumnCount).Value = VBA.Constants.vbNullString
Sheet.Cells(1, ColumnCount).Value = .Cells(1, ColumnCount).Value
ColumnCount = ColumnCount + 1
Loop
End If
' ---------------------------------------------------------------------------------------------
' Ensure we skip any headers. (set this value to the first row after the headers)
' ---------------------------------------------------------------------------------------------
lRow = 2
' ---------------------------------------------------------------------------------------------
' Determine last Master sheet row
' ---------------------------------------------------------------------------------------------
lCurrRow = 1
Do Until Sheet.Range("A" & lCurrRow).Value = VBA.Constants.vbNullString
lCurrRow = lCurrRow + 1
Loop
' ---------------------------------------------------------------------------------------------
' We are assuming the value in column A will be filled and there is no breaks until the
' end of our entries. If this is not the case additional code will be needed to
' determine the end of our entries.
' ---------------------------------------------------------------------------------------------
WriteTimeStampedEntry "Starting data collection for " & Filename
Do Until .Range("A" & lRow).Value = vbNullString
n = 0
Do Until .Cells(1, n + 1).Value = VBA.Constants.vbNullString
Sheet.Range("A" & lCurrRow).Offset(ColumnOffset:=n).Value = .Range("A" & lRow).Offset(ColumnOffset:=n).Value
n = n + 1
Loop
lRow = lRow + 1
lCurrRow = lCurrRow + 1
Loop
WriteTimeStampedEntry "Finished data collection for " & Filename
End With
NextSheet:
Next
NextI:
wb.Close SaveChanges:=False
WriteTimeStampedEntry "Closed out " & Filename
SkipFile:
Loop Until FindNextFile(hInstance, wFile) = 0
FindClose hInstance
Set wb = Nothing
End Sub
Function GetSheetName(ByVal Index As Long) As String
Select Case Index
Case 1: GetSheetName = SHEET_NAME_1
Case 2: GetSheetName = SHEET_NAME_2
Case 3: GetSheetName = SHEET_NAME_3
Case 4: GetSheetName = SHEET_NAME_4
Case 5: GetSheetName = SHEET_NAME_5
Case 6: GetSheetName = SHEET_NAME_6
Case 7: GetSheetName = SHEET_NAME_7
Case 8: GetSheetName = SHEET_NAME_8
End Select
End Function
Sub WriteTimeStampedEntry(ByVal msg As String)
Dim oFileSystem
Dim oTextStream
Set oFileSystem = CreateObject("Scripting.FileSystemObject")
Set oTextStream = oFileSystem.OpenTextFile(ThisWorkbook.Path & "\CollectData.log", 8, True)
oTextStream.WriteLine Now() & ": " & msg
oTextStream.Close
Set oTextStream = Nothing
Set oFileSystem = Nothing
End Sub
