Option Explicit
Sub Test__Get_All_Source_File_Names_With_This_File_Extension_From_This_FolderPath_Along_With_All_Of_Their_Sheet_Names_And_Put_Them_Into_A_Directory_Table_In_This_Sheet()
Call Get_All_Source_File_Names_With_This_File_Extension_From_This_FolderPath_Along_With_All_Of_Their_Sheet_Names_And_Put_Them_Into_A_Directory_Table_In_This_Sheet( _
ThisWorkbook.Sheets("Data Retrieval Sheet").Range("A2").Value & "\", ".xlsx", _
"Data Retrieval Sheet", _
"C10:C256" _
)
End Sub
Sub Get_All_Source_File_Names_With_This_File_Extension_From_This_FolderPath_Along_With_All_Of_Their_Sheet_Names_And_Put_Them_Into_A_Directory_Table_In_This_Sheet( _
folderPath As String, _
desiredFileExtension As String, _
sheetWithDirectoryTable As String, _
rangeToCopyValuesFromEachSheet As String _
)
'This sub takes the folder path such that there is no "\" at the end. If there is one, it's omitted.
If SubString(folderPath, Len(folderPath), Len(folderPath)) = "\" Then folderPath = SubString(folderPath, 1, Len(folderPath) - 1)
'-----------------------------------------------------------
'Create a Table of Directories in this Master Excel Workbook
'-----------------------------------------------------------
With ThisWorkbook.Sheets(sheetWithDirectoryTable)
.UsedRange.Value = ""
.Range("A1").Value = "Folder Path of Source Files"
.Range("A1").RowHeight = 50
.Range("A1").WrapText = True
.Range("A1").ColumnWidth = 50
.Range("A2").Value = folderPath 'put the folder path name back for the future.
.Range("B3").ColumnWidth = 50
.Range("B3").Value = "Master File Name"
.Range("B4") = ThisWorkbook.Name
.Range("B5").Value = "Master File's Sheets:"
.Range("B5").Font.Bold = True
End With
Call Put_This_Array_In_This_Workbook_In_This_Sheet_In_This_Column( _
ThisWorkbook, _
sheetWithDirectoryTable, 6, 2, _
Return_All_Worksheet_Names_In_This_Excel_File(ThisWorkbook) _
)
Dim currentFileIndexNumber As Integer
currentFileIndexNumber = 0
Dim book As Workbook
Dim currentFileExtension As String
Dim currentFileName As String
Dim C As Collection 'https://stackoverflow.com/a/28054165
Dim Filee As Variant
Set C = GetFilesIn(folderPath)
For Each Filee In C
currentFileName = Filee
currentFileExtension = SubString(currentFileName, InStrRev(currentFileName, "."), Len(currentFileName))
If desiredFileExtension = currentFileExtension Then
currentFileName = SubString(currentFileName, InStrRev(currentFileName, "\") + 1, InStrRev(currentFileName, ".") - 1)
currentFileIndexNumber = currentFileIndexNumber + 1
Set book = Workbooks.Open(fileName:=folderPath & "\" & currentFileName & desiredFileExtension)
Call Put_This_Array_In_This_Workbook_In_This_Sheet_In_This_Column( _
ThisWorkbook, _
sheetWithDirectoryTable, 6, 2 + currentFileIndexNumber, _
Return_All_Worksheet_Names_In_This_Excel_File(book) _
)
With ThisWorkbook.Sheets(sheetWithDirectoryTable).Cells(5, currentFileIndexNumber + 2)
.Value = book.Name
.Font.Bold = True
End With
book.Close savechanges:=False
Set book = Nothing
End If
Next Filee
ThisWorkbook.Sheets(sheetWithDirectoryTable).Range("B2").Formula = "=COUNTA(B3:B1000) + 2" 'It's unlikely an Excel file will have more than 1000 worksheets!
ThisWorkbook.Sheets(sheetWithDirectoryTable).Range("C2").Formula = "=COUNTA(C3:C1000) + 4"
ThisWorkbook.Sheets(sheetWithDirectoryTable).Range("C2:" & Column_Number_To_Letter(currentFileIndexNumber + 2) & "2").Formula = ThisWorkbook.Sheets(sheetWithDirectoryTable).Range("C2").Formula
'---------------------------------------------------------------------------------------
'Now search/compare the sheet names of This Workbook to those of the source Excel files'
'---------------------------------------------------------------------------------------
Dim lastRowWithSheetNamesForMasterWorkbook As Integer
lastRowWithSheetNamesForMasterWorkbook = ThisWorkbook.Sheets(sheetWithDirectoryTable).Cells(2, 2).Value
Dim lastRowWithDataSheetNamesForThisSourceWorkbook As Integer
Dim workbookIsAlreadyOpened As Boolean
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim sheetNameToUpdate As String
j = 3
Do While j <= currentFileIndexNumber + 2 'This variable is now the total number of source files. Counter for going across columns.
lastRowWithDataSheetNamesForThisSourceWorkbook = ThisWorkbook.Sheets(sheetWithDirectoryTable).Cells(2, j).Value
k = 6
Do While k <= lastRowWithDataSheetNamesForThisSourceWorkbook 'Counter for going top to bottom in current source workbook column.
workbookIsAlreadyOpened = False
i = 6
Do While i <= lastRowWithSheetNamesForMasterWorkbook 'Counter for going top to bottom in the master sheet workbook column.
'Debug.Print j & ": " & lastRowWithDataSheetNamesForThisSourceWorkbook & ": " & k & ": " & i
If ThisWorkbook.Sheets(sheetWithDirectoryTable).Cells(i, 2).Value = ThisWorkbook.Sheets(sheetWithDirectoryTable).Cells(k, j).Value Then
sheetNameToUpdate = ThisWorkbook.Sheets(sheetWithDirectoryTable).Cells(i, 2).Value
Debug.Print "Sheet '" & sheetNameToUpdate & "' from the master workbook is in the source Excel file: '" & ThisWorkbook.Sheets(sheetWithDirectoryTable).Cells(5, j).Value & "'"
If workbookIsAlreadyOpened = False Then
Set book = Workbooks.Open(fileName:=folderPath & "\" & ThisWorkbook.Sheets(sheetWithDirectoryTable).Cells(5, j).Value)
workbookIsAlreadyOpened = True
End If
ThisWorkbook.Sheets(sheetNameToUpdate).Range(rangeToCopyValuesFromEachSheet).Value = book.Sheets(sheetNameToUpdate).Range(rangeToCopyValuesFromEachSheet).Value
End If
i = i + 1
Loop
If workbookIsAlreadyOpened = True Then book.Close savechanges:=False
Set book = Nothing
k = k + 1
Loop
j = j + 1
Loop
End Sub
Function GetFilesIn(Folder As String) As Collection
Dim F As String
Set GetFilesIn = New Collection
F = Dir(Folder & "\*")
Do While F <> ""
GetFilesIn.Add F
F = Dir
Loop
End Function
Sub Test__Put_This_Array_In_This_Workbook_In_This_Sheet_In_This_Column()
Call Put_This_Array_In_This_Workbook_In_This_Sheet_In_This_Column( _
ThisWorkbook, _
"Data Retrieval Sheet", 6, 2, _
Return_All_Worksheet_Names_In_This_Excel_File(ThisWorkbook) _
)
End Sub
Sub Put_This_Array_In_This_Workbook_In_This_Sheet_In_This_Column(book As Workbook, sheetName As String, startRow As Long, columnNumber As Integer, arr As Variant)
Dim i As Long
Dim j As Integer
j = 1
i = startRow
Do While j <= UBound(arr)
book.Sheets(sheetName).Cells(i, columnNumber).Value = arr(j)
i = i + 1
j = j + 1
Loop
End Sub
Sub Test__Return_All_Worksheet_Names_In_This_Excel_File()
MsgBox Return_All_Worksheet_Names_In_This_Excel_File(ThisWorkbook)(1)
End Sub
Function Return_All_Worksheet_Names_In_This_Excel_File(book As Workbook)
ReDim arrayOfSheetNames(0 To 0) As String
Dim sht As Worksheet
For Each sht In book.Sheets
If (sht.Visible = -1) And (sht.Name <> "Data Retrieval Sheet") Then 'If the sheet is visible in the current workbook,
arrayOfSheetNames = Append_StringType(arrayOfSheetNames, sht.Name)
'Debug.Print arrayOfSheetNames(UBound(arrayOfSheetNames))
End If
Next sht
Return_All_Worksheet_Names_In_This_Excel_File = arrayOfSheetNames
End Function
Sub Test__Append_StringType()
ReDim sampleArray(1 To 2) As String
sampleArray(1) = "item 1"
sampleArray(2) = "item 2"
sampleArray = Append_StringType(sampleArray, "##Address_1 Line 1##")
MsgBox sampleArray(1)
MsgBox sampleArray(2)
End Sub
Function Append_StringType(arr As Variant, arg As Variant)
'Two possible errors from client subs:
'(1) arr is not of type variant.
'(2) arr is defined as Dim array() as Variant instead of ReDim array(1 to x) as variant.
Dim lowerBOundOfInputArray As Integer
lowerBOundOfInputArray = LBound(arr)
Dim upperBoundOfInputArray As Integer
upperBoundOfInputArray = UBound(arr)
ReDim newArray(lowerBOundOfInputArray To upperBoundOfInputArray) As String
newArray = arr
ReDim Preserve newArray(lowerBOundOfInputArray To upperBoundOfInputArray + 1)
newArray(upperBoundOfInputArray + 1) = arg
Append_StringType = newArray
End Function
Sub Test__SubString()
MsgBox SubString("ABCDEF", 3, 5)
End Sub
Function SubString(inputString As String, Start As Integer, Finish As Integer)
On Error GoTo Quit
SubString = Mid(inputString, Start, Finish - Start + 1)
Quit:
End Function
Sub Test__Column_Number_To_Letter()
MsgBox Column_Number_To_Letter(4)
MsgBox Column_Number_To_Letter(44)
End Sub
Function Column_Number_To_Letter(columnNumber As Integer) As String
'From https://stackoverflow.com/questions/12796973/function-to-convert-column-number-to-letter
Dim vArr
vArr = Split(Cells(1, columnNumber).Address(True, False), "$")
Column_Number_To_Letter = vArr(0)
End Function
