Importing Multiple Databases from one folder

[JamesSykes]

Hi,

I am relatively new to Access and VBA. I am trying to import a number of database files (just really want the contents of their tables) from a specified folder into a master table that contains all records and is updated periodically (via imports).
I have tried using a batch process (this limits me to importing specified files) but ideally would like to be able just to import all databases (or just their respective tables) irrespective of the number of files in the folder.
I am using Microsoft Access 2000 on a Windows XP PC. Any ideas or perhaps another way to import would be much appreciated. Either post here or email me at [email removed]

Cheers

James

[Rabbit]

I have something like this at work. It's not fully automated but it can be with some modifications to the code. I don't get into the office until tomorrow but when I do I'll post my code.

[ADezii]

Hi,

I am relatively new to Access and VBA. I am trying to import a number of database files (just really want the contents of their tables) from a specified folder into a master table that contains all records and is updated periodically (via imports).
I have tried using a batch process (this limits me to importing specified files) but ideally would like to be able just to import all databases (or just their respective tables) irrespective of the number of files in the folder.
I am using Microsoft Access 2000 on a Windows XP PC. Any ideas or perhaps another way to import would be much appreciated. Either post here or email me at [email removed]

Cheers

James

Here is a Sub-Routine that accepts an Absolute Path to your Database, the Table Name you wish to Import, and the New Table name that you wish to give it. It checks for the prior existance of the Table Name (previous Import), Deletes it if necessary, Imports the Table, then appends all its Records into tblMaster. The major assumption here, of course, is that the Imported Tables as well as the Master, have the same structure. Have fun.

Public Sub ImportAndAppend(strDBName As String, strTableName As String, strNewTableName As String)
Dim MyTable As TableDef, MySQL As String
 
MySQL = "INSERT INTO tblMaster SELECT " & strNewTableName & ".* FROM " & strNewTableName
 
DoCmd.SetWarnings False
 
For Each MyTable In CurrentDb.TableDefs
  If MyTable.Name = strNewTableName Then
    CurrentDb().TableDefs.Delete strNewTableName
      Exit For
  End If
Next
 
  DoCmd.TransferDatabase acImport, "Microsoft Access", strDBName, acTable, strTableName, strNewTableName, False
 
  DoCmd.RunSQL MySQL
 
DoCmd.SetWarnings True
End Sub

Here are your typical calls:

Call ImportAndAppend("C:\Test Directory\Test.mdb", "tblEmployee", "tblEmployee2")
Call ImportAndAppend("C:\Pension\Test.mdb", "tblEmployee", "tblEmployeePension")

[Rabbit]

Here is my form module. You can tear up this code and set up some sort of loop to append each file. This code right now only appends the file selected by the user. Comments on the code will follow in the next post.

Option Compare Database
Option Explicit
 
Private Sub but_Append_Click()
 
If IsNull(Month) Or IsNull(Year) Then
    MsgBox "Please Select Month and Year"
    End
End If
 
If IsNull(FileList.Column(0)) Or FileList.Column(0) = "No Files Found." Then End
 
Dim path, npath As String
Dim db As Database
Dim rst As Recordset
Dim PID As Integer
Dim temp As Variant
Dim DateCreated, DataMonth, PName, SName As String
 
Set db = CurrentDb
 
path = Application.CurrentProject.path & "\" & FileList.Column(0)
DoCmd.TransferDatabase acImport, "Microsoft Access", path, acTable, "tbl_MainOut", "tbl_MainOut"
DoCmd.TransferDatabase acImport, "Microsoft Access", path, acTable, "tbl_JobsOut", "tbl_JobsOut"
DoCmd.DeleteObject acTable, "tbl_Main_Backup"
DoCmd.DeleteObject acTable, "tbl_Jobs_Backup"
DoCmd.CopyObject , "tbl_Main_Backup", acTable, "tbl_Main"
DoCmd.CopyObject , "tbl_Jobs_Backup", acTable, "tbl_Jobs"
 
Set rst = db.OpenRecordset("tbl_MainOut")
rst.MoveFirst
temp = rst.GetRows(1)
PID = temp(0, 0)
DoCmd.SetWarnings False
DoCmd.RunSQL "DELETE FROM tbl_Main WHERE PID = " & PID
DoCmd.RunSQL "DELETE FROM tbl_Jobs WHERE PID = " & PID
DoCmd.RunSQL "INSERT INTO tbl_Main SELECT * FROM tbl_MainOut"
DoCmd.RunSQL "INSERT INTO tbl_Jobs SELECT * FROM tbl_JobsOut"
DoCmd.RunSQL "SELECT tbl_CodeProvider.Short, tbl_CodeProvider.Name INTO tbl_CurrentProvider FROM tbl_MainOut INNER JOIN tbl_CodeProvider ON tbl_MainOut.PID = tbl_CodeProvider.PID"
DoCmd.SetWarnings True
 
rst.Close
 
DoCmd.DeleteObject acTable, "tbl_MainOut"
DoCmd.DeleteObject acTable, "tbl_JobsOut"
 
Set rst = db.OpenRecordset("tbl_CurrentProvider")
rst.MoveFirst
temp = rst.GetRows(1)
PName = temp(1, 0)
SName = temp(0, 0)
 
npath = Application.CurrentProject.path & "\Providers\" & SName & "\" & FileList.Column(0)
FileCopy path, npath
db.Close
SetAttr path, vbNormal
Kill path
 
DateCreated = Mid(FileList.Column(0), 22, Len(FileList.Column(0)) - 25)
DataMonth = Month & "/" & Year
DoCmd.SetWarnings False
DoCmd.RunSQL "INSERT INTO tbl_Log VALUES (" & PID & ", '" & DateCreated & "', '" & DataMonth & "', Date())"
DoCmd.SetWarnings True
Check
 
MsgBox "Data for " & PName & " has been appended for " & DataMonth & "."
 
End Sub
 
Private Sub but_Close_Click()
DoCmd.Close acForm, "frm_Append"
End Sub
 
Private Sub Form_Load()
Check
End Sub
 
Function Check()
With Application.FileSearch
    Dim length As Integer
    length = Len(Application.CurrentProject.path) + 2
    .NewSearch
    .LookIn = Application.CurrentProject.path
    .SearchSubFolders = False
    .FileName = "CDCR CCRC-PSC Export"
    .MatchTextExactly = False
    .FileType = msoFileTypeDatabases
 
    If .Execute() > 0 Then
        Dim i As Integer
        Dim Files As String
        Files = "'" & Mid(.FoundFiles(1), length) & "'"
        For i = 2 To .FoundFiles.Count
            Files = Files & ";'" & Mid(.FoundFiles(i), length) & "'"
        Next i
        FileList.RowSource = Files
    Else
        FileList.RowSource = "'No Files Found.'"
    End If
End With
End Function
 

[Rabbit]

Option Compare Database
Option Explicit
 
Private Sub but_Append_Click()
 
If IsNull(Month) Or IsNull(Year) Then
    MsgBox "Please Select Month and Year"
    End
End If
 

FileList is a List Box that is populated using the function Check().

If IsNull(FileList.Column(0)) Or FileList.Column(0) = "No Files Found." Then Exit Sub
 
Dim path, npath As String
Dim db As Database
Dim rst As Recordset
Dim PID As Integer
Dim temp As Variant
Dim DateCreated, DataMonth, PName, SName As String
 
Set db = CurrentDb
 

FileList.Column (0) refers to the first column of the selected item from the list box. This code assumes that the databases are in the same folder as the consolidation database.

path = Application.CurrentProject.Path & "\" & FileList.Column(0)
DoCmd.TransferDatabase acImport, "Microsoft Access", path, acTable, "tbl_MainOut", "tbl_MainOut"
DoCmd.TransferDatabase acImport, "Microsoft Access", path, acTable, "tbl_JobsOut", "tbl_JobsOut"
DoCmd.DeleteObject acTable, "tbl_Main_Backup"
DoCmd.DeleteObject acTable, "tbl_Jobs_Backup"
DoCmd.CopyObject , "tbl_Main_Backup", acTable, "tbl_Main"
DoCmd.CopyObject , "tbl_Jobs_Backup", acTable, "tbl_Jobs"
 

This next part of the code does a conditional delete. Here's how our system works. We receive the data from multiple programs each month. Every time they send the data, they send their full data, not just the new records. So each program has a Program ID (PID). When we go to consolidate the data, we delete all the records with that PID and then append the new records we just imported.

Set rst = db.OpenRecordset("tbl_MainOut")
rst.MoveFirst
temp = rst.GetRows(1)
PID = temp(0, 0)
DoCmd.SetWarnings False
DoCmd.RunSQL "DELETE FROM tbl_Main WHERE PID = " & PID
DoCmd.RunSQL "DELETE FROM tbl_Jobs WHERE PID = " & PID
DoCmd.RunSQL "INSERT INTO tbl_Main SELECT * FROM tbl_MainOut"
DoCmd.RunSQL "INSERT INTO tbl_Jobs SELECT * FROM tbl_JobsOut"
DoCmd.RunSQL "SELECT tbl_CodeProvider.Short, tbl_CodeProvider.Name INTO tbl_CurrentProvider FROM tbl_MainOut INNER JOIN tbl_CodeProvider ON tbl_MainOut.PID = tbl_CodeProvider.PID"
DoCmd.SetWarnings True
 
rst.Close
 
DoCmd.DeleteObject acTable, "tbl_MainOut"
DoCmd.DeleteObject acTable, "tbl_JobsOut"
 

This next part moves the file that was just appended to an archive folder that is composed of their Provider Name (SName).

Set rst = db.OpenRecordset("tbl_CurrentProvider")
rst.MoveFirst
temp = rst.GetRows(1)
PName = temp(1, 0)
SName = temp(0, 0)
 
npath = Application.CurrentProject.path & "\Providers\" & SName & "\" & FileList.Column(0)
FileCopy path, npath
db.Close
SetAttr path, vbNormal
Kill path
 

This here appends a record into a log that this program last provided us data on some date, This date is a part of the filename as all exports that we receive from the program directors are named using the same convention. "Program Name Export Date Created.mdb". Then we run Check() again to refresh the List Box.

DateCreated = Mid(FileList.Column(0), 22, Len(FileList.Column(0)) - 25)
DataMonth = Month & "/" & Year
DoCmd.SetWarnings False
DoCmd.RunSQL "INSERT INTO tbl_Log VALUES (" & PID & ", '" & DateCreated & "', '" & DataMonth & "', Date())"
DoCmd.SetWarnings True
 
Check
 
MsgBox "Data for " & PName & " has been appended for " & DataMonth & "."
 
End Sub
 
Private Sub but_Close_Click()
DoCmd.Close acForm, "frm_Append"
End Sub
 
Private Sub Form_Load()
Check
End Sub
 
Function Check()
With Application.FileSearch
    Dim length As Integer
    length = Len(Application.CurrentProject.path) + 2
    .NewSearch
    .LookIn = Application.CurrentProject.path
    .SearchSubFolders = False
    .FileName = "CDCR CCRC-PSC Export"
    .MatchTextExactly = False
    .FileType = msoFileTypeDatabases
 
    If .Execute() > 0 Then
        Dim i As Integer
        Dim Files As String
        Files = "'" & Mid(.FoundFiles(1), length) & "'"
        For i = 2 To .FoundFiles.Count
            Files = Files & ";'" & Mid(.FoundFiles(i), length) & "'"
        Next i
        FileList.RowSource = Files
    Else
        FileList.RowSource = "'No Files Found.'"
    End If
End With
End Function
 

This code is about a month old and I've learned a bit since then. So I'm sure optimizations could be made to it. But it works and you should be able to scrap a lot of it for your purposes.