Consolidate Worksheet from a Folder and Append by Column - excel

Question

I have to compile all the worksheets in a folder and append it by column (in addition to labelling the file name).
All of the worksheets are expected to have the following dimensions.
I am expected to provide the following outcome (to be able to merge the file name is a bonus):
Sub macro1()
'Define variables
Dim wbk As Workbook
Dim Filename As String
Dim Path As String
i = 3
ThisWorkbook.Activate
'Location of individual templates
Path = "filename\"
Filename = Dir(Path & "*.xlsx")
'Prevents screen from flickering when Macro is running
Application.ScreenUpdating = False
'Start of loop
Do While Len(Filename) > 0
'Opens excel file
Set wbk = Workbooks.Open(Path & Filename)
'Copies the file names
Sheets("1.Consol").Select
Range("C3:E3").Select
ActiveCell.Value = Replace(Filename, ".xlsx", "")
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
'Labelling low
Range("C4").Select
ActiveCell.Value = "Low"
Range("C4").Select
Selection.Copy
Selection.PasteSpecial xlPasteValues
'Labelling Medium
Range("D4").Select
ActiveCell.Value = "Medium"
Range("D4").Select
Selection.Copy
Selection.PasteSpecial xlPasteValues
'Labelling High
Range("E4").Select
ActiveCell.Value = "High"
Range("E4").Select
Selection.Copy
Selection.PasteSpecial xlPasteValues
'Copies the whole range of data
Range("C3:E100").Copy
'Change to the sheet name you want to paste to
ThisWorkbook.Activate
Sheets("1.Consol").Select
Cells(3, i).Select
ActiveSheet.Paste
Selection.EntireColumn.ColumnWidth = 10
Selection.EntireRow.AutoFit
i = i + 3
Application.DisplayAlerts = False
wbk.Saved = True
wbk.Close True
Filename = Dir
Loop
End Sub

Answer 1

Based on this set up (see the location of data)
Source files:
Consolidated file:
Step through the code pressing F8 key
Read code's comments and adjust it to fit your needs
Public Sub OpenFilesAndCopyContents()
' Basic error handling
On Error GoTo CleanFail
' Turn off stuff
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
ThisWorkbook.UpdateLinks = xlUpdateLinksNever
' Define files path
Dim filesPath As String
filesPath = "C:\Temp\Test\"
' Define and set target sheet
Dim targetSheet As Worksheet
Set targetSheet = ThisWorkbook.Worksheets("1.Consol")
' Define initial cell in target sheet
Dim targetRange As Range
Set targetRange = targetSheet.Range("B1")
' Define file name string to match
Dim fileString As String
fileString = "samplefile"
' Define file name
Dim fileName As String
fileName = Dir(filesPath, vbNormal)
' Start a counter for worksheets
Dim sheetCounter As Long
' Loop through files
Do While fileName <> ""
'Set variable equal to opened workbook
If InStr(LCase(fileName), LCase(fileString)) > 0 Then
' Set a reference to the workbook
Dim sourceWorkbook As Workbook
Set sourceWorkbook = Workbooks.Open(fileName:=filesPath & fileName, UpdateLinks:=False)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
' Loop through sheets in workbook
Dim sourceSheet As Worksheet
For Each sourceSheet In sourceWorkbook.Worksheets
' Add workbook and worksheet as title
targetRange.Offset(0, sheetCounter).Value = sourceWorkbook.Name & " " & sourceSheet.Name
' Copy paste values from worksheet
sourceSheet.Range("B1:D8").Copy targetRange.Offset(1, sheetCounter)
sheetCounter = sheetCounter + 3
Next sourceSheet
'Close Workbook without saving
sourceWorkbook.Close SaveChanges:=False
'Ensure Workbook has closed before moving on to next line of code
DoEvents
End If
fileName = Dir()
Loop
CleanExit:
' Turn on stuff
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
ThisWorkbook.UpdateLinks = xlUpdateLinksAlways
Exit Sub
CleanFail:
MsgBox "Error " & Err.Description
GoTo CleanExit
End Sub
Let me know if it works