here’s a single, ready-to-paste Access VBA module that does exactly what you described:
📌 Set your sheet name and first data row in the “SETTINGS” section at the top.
Option Compare Database
Option Explicit
' ====== SETTINGS YOU CAN CHANGE ======
Private Const TARGET_TABLE As String = "All_Excel_Data" ' final table (with SourceFile/SourceSheet)
Private Const STAGING_TABLE As String = "_ImportStage" ' temp table; recreated per file
' Import only this worksheet (tab) from every workbook (no trailing $)
Private Const IMPORT_ONLY_SHEET As String = "Data" ' <-- change to your tab name
' Where the real table starts on that sheet (skip merged/title rows above this)
Private Const START_ROW As Long = 5 ' <-- first row to import
Private Const ROW_CONTAINS_HEADERS As Boolean = True ' True if START_ROW has field names
' Column span for the import range:
' - Set COL_START and (optionally) COL_END to force a fixed span (e.g., "A" to "Z")
' - Leave COL_END = "" and keep DETECT_LAST_COL = True to auto-detect right edge via Excel.
Private Const COL_START As String = "A"
Private Const COL_END As String = ""
' Auto-detect bounds using Excel (late binding; no references needed)
Private Const DETECT_LAST_ROW As Boolean = True
Private Const DETECT_LAST_COL As Boolean = True
' Optional saved import spec (pins data types) — leave "" if you don't use one
Private Const IMPORT_SPEC As String = ""
' =====================================
Public Sub Import_Excel_Folder()
On Error GoTo Fail
Dim folder As String: folder = PickFolder()
If Len(folder) = 0 Then Exit Sub
InitLogTable
Dim f As String, full As String
Dim imported As Long, skipped As Long
Dim startTime As Date: startTime = Now
' Only .xlsx files (per your setup)
f = Dir(AddSlash(folder) & "*.xlsx")
Do While Len(f) > 0
full = AddSlash(folder) & f
If ImportSingleFile(full) Then
imported = imported + 1
Else
skipped = skipped + 1
End If
f = Dir
Loop
MsgBox "Done." & vbCrLf & _
"Imported workbooks: " & imported & vbCrLf & _
"Skipped (see ImportLog): " & skipped & vbCrLf & _
"Target table: " & TARGET_TABLE & vbCrLf & _
"Elapsed: " & Format(Now - startTime, "hh:nn:ss"), vbInformation
Exit Sub
Fail:
LogError "Import_Excel_Folder", Err.Number, Err.Description, ""
MsgBox "Unexpected error: " & Err.Description, vbExclamation
End Sub
' ---------- Import exactly one sheet from a workbook, add provenance, append ----------
Private Function ImportSingleFile(fullPath As String) As Boolean
On Error GoTo Fail
Dim rng As String
rng = BuildRange(fullPath, IMPORT_ONLY_SHEET, START_ROW)
If Len(rng) = 0 Then
LogError "ImportSingleFile", 0, "Failed to build range.", fullPath
GoTo FailExit
End If
' Recreate staging table fresh for this file
DropTableIfExists STAGING_TABLE
' Import the specified range into staging
If Len(IMPORT_SPEC) > 0 Then
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, _
STAGING_TABLE, fullPath, ROW_CONTAINS_HEADERS, rng, IMPORT_SPEC
Else
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, _
STAGING_TABLE, fullPath, ROW_CONTAINS_HEADERS, rng
End If
' Create/append to final table with provenance columns
Dim sf As String, ss As String
sf = Replace(fullPath, "'", "''")
ss = Replace(IMPORT_ONLY_SHEET, "'", "''")
If Not TableExists(TARGET_TABLE) Then
' First file: create final table with SourceFile/SourceSheet added
CurrentDb.Execute _
"SELECT s.*, '" & sf & "' AS SourceFile, '" & ss & "' AS SourceSheet " & _
"INTO [" & TARGET_TABLE & "] FROM [" & STAGING_TABLE & "] AS s;", dbFailOnError
Else
' Next files: append
CurrentDb.Execute _
"INSERT INTO [" & TARGET_TABLE & "] " & _
"SELECT s.*, '" & sf & "' AS SourceFile, '" & ss & "' AS SourceSheet " & _
"FROM [" & STAGING_TABLE & "] AS s;", dbFailOnError
End If
' Optional: drop staging to keep DB tidy
DropTableIfExists STAGING_TABLE
ImportSingleFile = True
Exit Function
Fail:
LogError "ImportSingleFile", Err.Number, Err.Description, fullPath & " :: " & IMPORT_ONLY_SHEET
FailExit:
End Function
' ---------- Build "'Sheet Name$A5:Z999999'" (quoted; auto-detected end if enabled) ----------
Private Function BuildRange(fullPath As String, sheetName As String, startRow As Long) As String
On Error GoTo Fail
Dim cStart As String: cStart = IIf(Len(COL_START) > 0, COL_START, "A")
Dim cEnd As String: cEnd = COL_END
Dim lastRow As Long: lastRow = 0
Dim lastCol As Long: lastCol = 0
' Auto-detect bounds via Excel if requested or if COL_END not provided
If DETECT_LAST_ROW Or DETECT_LAST_COL Or Len(cEnd) = 0 Then
If Not GetLastRowCol(fullPath, sheetName, lastRow, lastCol) Then
' Fallbacks
If lastRow = 0 Then lastRow = 1048576
If lastCol = 0 Then lastCol = ColLetterToNumber(IIf(Len(COL_END) > 0, COL_END, "Z"))
End If
End If
' If user didn't force COL_END, use detected lastCol (converted to letter)
If Len(cEnd) = 0 Then
cEnd = ColNumberToLetter(IIf(lastCol > 0, lastCol, ColLetterToNumber("Z")))
End If
' Ensure lastRow makes sense
If Not DETECT_LAST_ROW Then
If lastRow < startRow Then lastRow = 1048576
End If
If lastRow = 0 Then lastRow = 1048576
' Wrap sheet name in single quotes to support spaces/special chars
BuildRange = "'" & sheetName & "$" & cStart & CStr(startRow) & ":" & cEnd & CStr(lastRow) & "'"
Exit Function
Fail:
LogError "BuildRange", Err.Number, Err.Description, fullPath
BuildRange = ""
End Function
' ---------- Excel late-binding to detect last used row/col (no references needed) ----------
Private Function GetLastRowCol(fullPath As String, sheetName As String, _
ByRef lastRow As Long, ByRef lastCol As Long) As Boolean
On Error GoTo Fail
Dim xl As Object, wb As Object, ws As Object, used As Object
Set xl = CreateObject("Excel.Application")
xl.DisplayAlerts = False
xl.Visible = False
Set wb = xl.Workbooks.Open(fullPath, False, True) ' read-only
On Error Resume Next
Set ws = wb.Sheets(sheetName)
On Error GoTo Fail
If ws Is Nothing Then GoTo Fail
If ws.UsedRange Is Nothing Then GoTo Fail
Set used = ws.UsedRange
lastRow = used.Row + used.Rows.Count - 1
lastCol = used.Column + used.Columns.Count - 1
wb.Close False
xl.Quit
Set ws = Nothing: Set wb = Nothing: Set xl = Nothing
GetLastRowCol = (lastRow > 0 And lastCol > 0)
Exit Function
Fail:
On Error Resume Next
If Not wb Is Nothing Then wb.Close False
If Not xl Is Nothing Then xl.Quit
Set ws = Nothing: Set wb = Nothing: Set xl = Nothing
GetLastRowCol = False
End Function
' ---------- Utilities ----------
Private Function PickFolder() As String
' Folder picker defaults to My Documents (works with local or OneDrive "Documents")
Dim fd As Object
Set fd = Application.FileDialog(4) ' 4 = msoFileDialogFolderPicker
With fd
.Title = "Pick the folder containing your .xlsx files"
.AllowMultiSelect = False
.InitialFileName = AddSlash(MyDocumentsPath)
If .Show = -1 Then
PickFolder = .SelectedItems(1)
Else
PickFolder = ""
End If
End With
End Function
Private Function MyDocumentsPath() As String
On Error Resume Next
Dim sh As Object
Set sh = CreateObject("WScript.Shell")
MyDocumentsPath = sh.SpecialFolders("MyDocuments")
If Len(MyDocumentsPath) = 0 Then
MyDocumentsPath = Environ$("USERPROFILE") & "\Documents"
End If
End Function
Private Function AddSlash(p As String) As String
If Right$(p, 1) = "\" Or Right$(p, 1) = "/" Then AddSlash = p Else AddSlash = p & "\"
End Function
Private Sub DropTableIfExists(tbl As String)
On Error Resume Next
DoCmd.DeleteObject acTable, tbl
On Error GoTo 0
End Sub
Private Function TableExists(tbl As String) As Boolean
Dim t As DAO.TableDef
For Each t In CurrentDb.TableDefs
If t.Name = tbl Then TableExists = True: Exit Function
Next
End Function
Private Sub InitLogTable()
If Not TableExists("ImportLog") Then
CurrentDb.Execute _
"CREATE TABLE ImportLog (" & _
"LogID AUTOINCREMENT PRIMARY KEY," & _
"LogWhen DATETIME," & _
"WhereAt TEXT(100)," & _
"ErrNum LONG," & _
"ErrDesc TEXT(255)," & _
"Context TEXT(255));", dbFailOnError
End If
End Sub
Private Sub LogError(whereAt As String, errNum As Long, errDesc As String, ctx As String)
On Error Resume Next
InitLogTable
CurrentDb.Execute _
"INSERT INTO ImportLog (LogWhen, WhereAt, ErrNum, ErrDesc, Context) VALUES (" & _
"#" & Format(Now, "yyyy-mm-dd hh:nn:ss") & "#," & _
"'" & Replace(whereAt, "'", "''") & "'," & _
errNum & "," & _
"'" & Left$(Replace(errDesc, "'", "''"), 255) & "'," & _
"'" & Left$(Replace(ctx, "'", "''"), 255) & "'" & _
");"
End Sub
' ---- Column letter/number conversions ----
Private Function ColLetterToNumber(colLetter As String) As Long
Dim i As Long, n As Long
For i = 1 To Len(colLetter)
n = n * 26 + (Asc(UCase$(Mid$(colLetter, i, 1))) - 64)
Next
ColLetterToNumber = n
End Function
Private Function ColNumberToLetter(n As Long) As String
Dim s As String, r As Long
Do While n > 0
r = (n - 1) Mod 26
s = Chr$(65 + r) & s
n = (n - 1) \ 26
Loop
ColNumberToLetter = s
End Function
That’s it. If anything errors, check the ImportLog table for which file/sheet hiccupped. Want me to pin field types with an example Import Spec, or to add an ImportedAt timestamp column?
We use cookies to analyze website traffic and optimize your website experience. By accepting our use of cookies, your data will be aggregated with all other user data.