Adding Source File Name to First Column of Workbook (VBA) - excel

Question

I'm fairly new to using VBA, but I currently have a code written that does the following:
Searches within a folder, all excel files which contain a specific worksheet, and outputs in to a master sheet.
I am trying to add a column, either at the beginning or end of the master sheet which indicates the file source name. My code is the following
Sub CombineWorkbooks()
'Declare the variables
Dim arrFiles() As String
Dim strPath As String
Dim strFile As String
Dim wkbDest As Workbook
Dim wksDest As Worksheet
Dim wkbSource As Workbook
Dim wksSource As Worksheet
Dim SourceRange As Range
Dim SourceRowCount As Long
Dim NextRow As Long
Dim LastRow As Long
Dim LastCol As Long
Dim FileCnt As Long
Dim Cnt As Long
Dim i As Long
Dim CalcMode As Long
'Specify the path to the folder containing the files
strPath = "FOLDER PATH\"
'Make sure that the path ends in a backslash
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
'Check if the path exists
If Len(Dir(strPath, vbDirectory)) = 0 Then
MsgBox "The path to your folder does not exist. Please check" & vbCrLf & _
"the path, and try again!", vbExclamation
Exit Sub
End If
'Get the first Excel file from the folder
strFile = Dir(strPath & "*.xls", vbNormal)
'Fill the array with a list of Excel files in the folder...
FileCnt = 0
Do While Len(strFile) > 0
'...except this workbook, in case it's in the same folder
If strFile <> ThisWorkbook.Name Then
FileCnt = FileCnt + 1
ReDim Preserve arrFiles(1 To FileCnt)
arrFiles(FileCnt) = strFile
End If
'Get the next Excel file from the folder
strFile = Dir
Loop
'If no Excel files were found, exit the sub
If FileCnt = 0 Then
MsgBox "No Excel files were found...", vbExclamation
Exit Sub
End If
'Change the settings for Calculation, DisplayAlerts, EnableEvents,
'and ScreenUpdating
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
.EnableEvents = False
.ScreenUpdating = False
End With
'Create a new workbook with one worksheet
Set wkbDest = Workbooks.Add(xlWBATWorksheet)
'Set the destination worksheet
Set wksDest = wkbDest.Worksheets(1)
'Specify the row in which to start copying the data
NextRow = 1
'Loop through each Excel file in the array...
Cnt = 0
For i = LBound(arrFiles) To UBound(arrFiles)
'Open the current file
Set wkbSource = Workbooks.Open(strPath & arrFiles(i))
'Set the source worksheet
On Error Resume Next
Set wksSource = wkbSource.Worksheets("Worksheet you are looking to import")
On Error GoTo 0
'Check if the worksheet exists
If Not wksSource Is Nothing Then
With wksSource
'Find the last used row in Column A
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Find the last used column in Row 1
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
'Check if the worksheet contains data beyond column headers
If LastRow > 1 Then
'Increase the count by one
Cnt = Cnt + 1
'Set the source range...
If Cnt = 1 Then
'...including the column headers
Set SourceRange = .Range("A1", .Cells(LastRow, LastCol))
Else
'...excluding the column headers
Set SourceRange = .Range("A2", .Cells(LastRow, LastCol))
End If
'Count the number of rows in the source range
SourceRowCount = SourceRange.Rows.Count
'If there aren't enough rows in the destination sheet,
'exit the sub
If NextRow + SourceRowCount - 1 > wksDest.Rows.Count Then
MsgBox "Sorry, there are not enough rows available " & _
"in the destination worksheet!", vbExclamation
wkbSource.Close savechanges:=False
GoTo ExitSub
End If
'Copy the data from the source range to the destination sheet
SourceRange.Copy
With wksDest.Cells(NextRow, "A")
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
End With
'Determine the next available row
NextRow = NextRow + SourceRowCount
End If
End With
'Set the object variable for the source worksheet to Nothing
Set wksSource = Nothing
End If
'Close the current file, without saving it
wkbSource.Close savechanges:=False
Next i
'Check if any data has been copied to the destination worksheet
If Cnt > 0 Then
'Select the first cell and change the width of the columns to
'achieve the best fit
With wksDest
.Cells(1).Select
.Columns.AutoFit
End With
Else
'Display message box advising user that no data was available to be copied
MsgBox "No data was available to be copied...", vbInformation
'Close the destination workbook, without saving it
wkbDest.Close savechanges:=False
End If
ExitSub:
'Restore the settings for Calculation, DisplayAlerts, EnableEvents,
'and ScreenUpdating
With Application
.Calculation = CalcMode
.DisplayAlerts = True
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Any help would be greatly appreciated!

Answer 1

You might want to look at Power Query's "Import from folder" option. When you import all the files from a folder. Using PQ, you can import all the files from a folder (which appends the file name as a new column in the process) and combine and edit that information. One procedure you can do in Power Query is to navigate to a specific worksheet by its name. If you tried to do this navigation on a workbook that didn't have this name, it would cause an error to be raised. In PQ, you can also tell the query to remove any errors. Combined, you could gather all the files in various folders, using a file that has your specific worksheet, you can create a sample query to drill into that worksheet, and perform your other transformations. If you do this step, then remove all the errors, you should be left only with the files that have the worksheet you are looking for, and have the file name for each of those files alongside your data, and that can be dumped into a master table on your worksheet. Plus, you don't have to deal with any overly complicated VBA code (though, I do so love VBA).
Hope this helps!