VBA code to action 100 files in a folder

[Fuisdale2]

Is it possible to write a macro that would action all files in a certain folder with the below code?

The folder name and location will always stay the same but the name of the files within and the amount of files may change.

The macro would open them all, and run the below piece of code.

[Sub Import()
Dim vFile As Variant
Dim wbCopyTo As Workbook
Dim wsCopyTo As Worksheet
Dim wbCopyFrom As Workbook
Dim wsCopyFrom As Worksheet
Set wbCopyTo = ActiveWorkbook
Set wsCopyTo = wbCopyTo.Sheets("Imported_Data")
Application.DisplayAlerts = False

vFile = Application.GetOpenFilename

If TypeName(vFile) = "Boolean" Then
Exit Sub
Else
Set wbCopyFrom = Workbooks.Open(vFile)
Set wsCopyFrom = wbCopyFrom.Worksheets(1)
End If

Set oneRange = Range("A1:ll5000")
Set aCell = Range("A1")
'oneRange.Sort Key1:=aCell, Order1:=xlAscending, Header:=xlYes

wsCopyFrom.Range("a9:ll5000").Copy
wsCopyTo.Range("a1").PasteSpecial Paste:=xlValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
wbCopyFrom.Close False
Application.ScreenUpdating = False
Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
Dim intErrCount As Integer
' create worksheet objects
Dim shtSource As Worksheet: Set shtSource = Sheets("Imported_Data")
Dim shtTarget As Worksheet: Set shtTarget = Sheets("Database")
' create range objects
Dim rngSourceHeaders As Range: Set rngSourceHeaders = shtSource.Range("A1:BB1")
With shtTarget
Dim rngTargetHeaders As Range: Set rngTargetHeaders = .Range("A1:AB1") '.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft)) 'Or just .Range("A1:AB1")
Dim rngPastePoint As Range: Set rngPastePoint = .Cells(.Rows.Count, 1).End(xlUp).Offset(1) 'Shoots up from the bottom of the sheet untill it bumps into something and steps one down
End With

Dim rngDataColumn As Range
' process data
Dim cl As Range, i As Integer
For Each cl In rngTargetHeaders ' loop through each cell in target header row

' identify source location
i = 0 ' reset I
On Error Resume Next ' ignore errors, these are where the value can't be found and will be tested later
i = Application.Match(cl.Value, rngSourceHeaders, 0) 'Finds the matching column name
On Error GoTo 0 ' switch error handling back off

' report if source location not found
If i = 0 Then
intErrCount = intErrCount + 1
Debug.Print "unable to locate item [" & cl.Value & "] at " & cl.Address ' this reports to Immediate Window (Ctrl + G to view)
GoTo nextCL
End If

' create source data range object
With rngSourceHeaders.Cells(1, i)
Set rngDataColumn = Range(.Cells(2, 1), .Cells(1000000, 1).End(xlUp))
End With

' pass to target range object
shtTarget.Cells(Rows.Count, cl.Column).End(xlUp).Offset(1, 0).Resize(rngDataColumn.Rows.Count, rngDataColumn.Columns.Count).Value = rngDataColumn.Value


nextCL:
Next cl
Sheets("Database").Select
Range("A1").Select

End Sub]