Запрос с добавление столбцов названия таблиц и баз

Dim strBase As String, strSQL As String
Dim FolderPath As String
Dim objFSO As Object
Dim objFolder As Object
Dim colFiles As Object
Dim objFile As Object
 
Dim txtFind As String
Dim NameField As String
Dim db As Database
Dim tds As TableDefs
Dim td As TableDef
 
FolderPath = Nz(Me.plDirPath.Value, "") 'Папка в которой лежат файлы mdb, здесь plDirPath-поле на форме
 
If Len(FolderPath & "") = 0 Then
   MsgBox ("Не указана папка с mdb")
Else
   Set objFSO = CreateObject("Scripting.FileSystemObject")
   Set objFolder = objFSO.GetFolder(FolderPath)
   Set colFiles = objFolder.Files
   For Each objFile In colFiles
       If Right(objFile.Name, 4) = ".mdb" Then 'Если файл с расширением mdb
          Dim strFile As String
          strFile = FolderPath & "\" & objFile.Name
          Set db = OpenDatabase(strFile)
          Set tds = db.TableDefs
          For Each td In tds
              If Left(td.Name, 4) <> "MSys" Then 'MSys
                 strSQL = "INSERT INTO [ВашаТаблица] ( База, Таблица,Имя,Фамилия,Год) SELECT '" & objFile.Name & "', '" & td.Name & "', Имя, Фамилия, Год FROM [" & strFile & "].[" & td.Name & "];"
                 CurrentProject.Connection.Execute (strSQL)
                 '
              End If
          Next
          Set tds = Nothing
          Set db = Nothing
       End If
   Next
End If
 
Set objFSO = Nothing
Set objFolder = Nothing
Set colFiles = Nothing