Importing a folders worth of excel work books into Acess

[chrisbrocco]

Is there a way (using VBA) to point to a folder and make access import all the files (which will be excel files) into a access a table.

Prefrably beable to say which colums it imports

 

[ehuff]

OK, in case this is easier to answer, I have this working when I have a "DoCmd.TransferSpreadsheet" line for each file in my newest test (which is fairly quick and easy to do) but I cannot get it to look into sub-directories. Not sure if this is entirely related, but I have also noticed that Access seems to ignore the file paths in my code if they do not match the path I have entered under "Access Options / Creating Databases / Default database folder:" So, as it stands, I can get this to work for all 116 files if I add a "DoCmd.TransferSpreadsheet" command for each (as none of my wildcards have worked properly) and also have all of them in the same folder so that I eliminate the issue of sub-directories and the issue related to the Default database folder setting under Options. While I can get around both of these issues I would rather jsut have code that works, but I am not compitent enough to get their on my own. The code is below. Forgive me if I posted it incorrectly. I did try to find a post about "how to" first. Thanks.

Function ImportExcelFiles()
Dim strPathFile As String, strFile As String, strPath As String
Dim strTable As String
strPath = "C:\Access Test\BOTH\"
strFile = Dir(strPath & "*.xlsx")
MyName = Dir("C:\Access Test\BOTH\" & "*.xlsx", vbNormal)
    DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, "tbl_Results", "001 - Downtown Indiana", True, "For Management Use Only!A1:K53"
    DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, "tbl_Results", "002 - Plumville", True, "For Management Use Only!A1:K53"
    DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, "tbl_Results", "003 - South Fork", True, "For Management Use Only!A1:K53"
    DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, "tbl_Results", "004 - Blairsville", True, "For Management Use Only!A1:K53"
    DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, "tbl_Results", "005 - Regency Mall", True, "For Management Use Only!A1:K53"
    DoEvents 'don't take over all of the PC resources
    
strFile = Dir()

MsgBox "Import complete.", vbInformation, "Done"
End Function

 

[velu130486]

Hi Denis,

Actually I am new user to access and my problem is similar to this thread. So I copied your code and applied in my database, however it shows error in the following line.

With Application.FileSearch

Then I got a different code form Internet and applied it and it works for me.
Private Sub Command2_Click()
Dim strFile As String 'Filename
Dim strFileList() As String 'File Array
Dim intFile As Integer 'File Number
Dim filename As String
Dim path As String
DoCmd.SetWarnings False
path = "C:\Users\PSS700334\Desktop\3. EXCEL FILES\"

'Loop through the folder & build file list
strFile = Dir(path & "*.xls")

While strFile <> ""
'add files to the list
intFile = intFile + 1
ReDim Preserve strFileList(1 To intFile)
strFileList(intFile) = strFile
strFile = Dir()
Wend

'see if any files were found
If intFile = 0 Then
MsgBox "No files found"
Exit Sub
End If

'cycle through the list of files
For intFile = 1 To UBound(strFileList)
filename = path & strFileList(intFile)
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel8, "Check", filename, True
Next intFile
DoCmd.SetWarnings True

End Sub

Here's some sample code:

'Import from multiple sheets in multiple files, in a set folder.
'Note: This borrows heavily from code provided by andrew93.
'You will need to set a reference to the 'Microsoft Office x.0 Object Library'
'where x is your version number.
'This can be found under Tools > References in the VBA editor screen.
'You may also need to set a reference to Microsoft Scripting Runtime.

Function ImportExcelFiles()
Dim Counter As Integer

With Application.FileSearch
    .NewSearch
    .LookIn = "C:\ImportDir" 'change this to your actual directory
    .SearchSubFolders = False 'set to True if you want to search subfolders too
    .FileType = msoFileTypeAllFiles 'get all files in the directory -- ensure only Excel files are in this folder

    If .Execute() > 0 Then 'files found
        For Counter = 1 To .FoundFiles.Count 'loop through files
            .FileName = .FoundFiles(Counter) 'set / get the file name
            'Change the "ImportFile" part in the line below if you are using a different table name
            'Note: 1 command for each worksheet. I have assumed they are Sheet1 etc.
            DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel8, "ImportFile", .FileName, False, [Sheet1$]
            DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel8, "ImportFile", .FileName, False, [Sheet2$]
            DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel8, "ImportFile", .FileName, False, [Sheet3$]
            DoEvents 'don't take over all of the PC resources
        Next Counter
        MsgBox "Import complete.", vbInformation, "Done"
    Else 'files not found
        MsgBox "There were no files found.", vbCritical, "Error"
    End If
End With
End Function

Note: The False parameter in the TransferSpreadsheet commands indicates that columns don't have headers. If they do, change this to True

The best way to create the dummy table is to directly import one of the Excel files into Access, then delete the data and any "spare" fields from the table once it is in Access. The "spares" will have the descriptive names F1, F2, etc, and will follow the real field names.

Hope this helps
Denis

However my my objective is to get the Excel file name in the Access Table name "Check". Could you please help me to solve this issue.

Thanks and Regards
R.Vadivelan

 

[SydneyGeek]

Do you want to import the files into Check, or write the file names into a field in Check? Sorry, but your answer was unclear.
Also, thanks for pointing out the issue with the code, that was caused by Microsoft making changes to VBA when Office 2007 came out, which made Application.FileSearch unusable.

Denis

 

[velu130486]

Hi Denis,

I want to Import the Files along with the Excel File name.

Do you want to import the files into Check, or write the file names into a field in Check? Sorry, but your answer was unclear.
Also, thanks for pointing out the issue with the code, that was caused by Microsoft making changes to VBA when Office 2007 came out, which made Application.FileSearch unusable.

Denis

Following is the code which I am presently using for importing multiple excel files from a particular location. This code is working fine, However I have one missing data i.e ExcelFileName.
Private Sub Command2_Click()
Dim strFile As String 'Filename
Dim strFileList() As String 'File Array
Dim intFile As Integer 'File Number
Dim filename As String
Dim path As String
DoCmd.SetWarnings False
path = "C:\users-data\PSS700334\Documents\Inpex Masela FLNG\PCON\Access MDR\3. EXCEL FILES\"

'Loop through the folder & build file list
strFile = Dir(path & "*.xls")

While strFile <> ""
'add files to the list
intFile = intFile + 1
ReDim Preserve strFileList(1 To intFile)
strFileList(intFile) = strFile
strFile = Dir()
Wend

'see if any files were found
If intFile = 0 Then
MsgBox "No files found"
Exit Sub
End If

'cycle through the list of files
For intFile = 1 To UBound(strFileList)
filename = path & strFileList(intFile)
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel8, "CPYTransmittal", filename, True
Next intFile
DoCmd.SetWarnings True

End Sub

---

I want to send my sample database however I don't know how to attach and sorry for that.

Kindly help me to get the Excel file Name also by any method, since We are getting more than 200 files/day and it is very much important for me to track the status of the document.

And thank you very much for your help and forum members. It is very much useful for a learners like me.

Thanks and regards
R. Vadivelan

 

[SydneyGeek]

I would make these changes to allow the file name to be written:
1. Create a filename field in the destination table
2. Create a Timestamp field with the default value =Now().
After importing each file, run an Update query that writes the FileName string to the FileName field, where (a) the Timestamp is less than 5 mins ago and (b) the filename field is null.
Create the update query using the query builder. You can call it in code by doing something like:

DoCmd.OpenQuery "YourQueryName"
Note: Put this line immediately after the DoCmd.TransferSpreadsheet line.

Denis

 

[velu130486]

Hi Denis,

Thanks your reply. However my Objective is to Import the multiple files at once time along with excel file. I got the answer for the same in another forum with the following code and it solved my Purpose. Thanks for you giving the initial idea of this subject and thanks to Sinndho for finishing the subject matter.

Dim strFile As String 'Filename
Dim strFileList() As String 'File Array
Dim intFile As Integer 'File Number
Dim filename As String
Dim path As String
Dim strSQL As String

DoCmd.SetWarnings False
path = "D:\Access MDR\MDR\"

'Loop through the folder & build file list
strFile = Dir(path & "*.xls")

sSQL = "UPDATE CPYTransmittal SET CPYTransmittal.ExcelFileName = '@F'" _
& "WHERE CPYTransmittal.ExcelFileName Is Null;"

While strFile <> ""
'add files to the list
intFile = intFile + 1
ReDim Preserve strFileList(1 To intFile)
strFileList(intFile) = strFile
strFile = Dir()

Wend

'see if any files were found
If intFile = 0 Then
MsgBox "No files found"
Exit Sub
End If

'cycle through the list of files
For intFile = 1 To UBound(strFileList)
filename = path & strFileList(intFile)
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel8, "CPYTransmittal", filename, True
DoCmd.RunSQL Replace(sSQL, "@F", filename)
Next intFile

DoCmd.SetWarnings True

However I have one more query, (i.e) How to avoid importing of duplicate files again, (i.e) If the file is already imported then it should not import again. With the above code my data is imported, However I run the code again the files are duplicated. I had put the Primary key in Table, but it doesn't works

Thanks and Regards
R. Vadivelan

 

[BlackIron]

I am getting an error when trying to run the code
"Run-tim erro '2455':
You entered an expression that has an invalid reference to the property FileSearch.

Code Below
'Import from multiple sheets in multiple files, in a set folder.
'Note: This borrows heavily from code provided by andrew93.
'You will need to set a reference to the 'Microsoft Office x.0 Object Library'
'where x is your version number.
'This can be found under Tools > References in the VBA editor screen.
'You may also need to set a reference to Microsoft Scripting Runtime.
Function ImportExcelFiles()
Dim Counter As Integer



With Application.FileSearch
.NewSearch
.LookIn = "U:\Fix Testing" 'change this to your actual directory
.SearchSubFolders = False 'set to True if you want to search subfolders too
.FileType = msoFileTypeAllFiles 'get all files in the directory -- ensure only Excel files are in this folder
If .Execute() > 0 Then 'files found
For Counter = 1 To .FoundFiles.Count 'loop through files
.FileName = .FoundFiles(Counter) 'set / get the file name
'Change the "ImportFile" part in the line below if you are using a different table name
'Note: 1 command for each worksheet. I have assumed they are Sheet1 etc.
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel8, "Table1", .FileName, False
'DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel8, "ImportFile", .FileName, False, [Sheet2$]
'DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel8, "ImportFile", .FileName, False, [Sheet3$]
DoEvents 'don't take over all of the PC resources
Next Counter
MsgBox "Import complete.", vbInformation, "Done"
Else 'files not found
MsgBox "There were no files found.", vbCritical, "Error"
End If
End With
End Function

 

[SydneyGeek]

The problem is with Application.FileSearch, which no longer works.
You will need to use Dir instead. See the post before yours: Everything from DoCmd.SetWarnings False to DoCmd.SetWarnings True is relvant for the Dir version to work.

Denis

 

[BlackIron]

Thanks, Sydney Geek

I found the below code worked for me.

Is there a way to delete the first row in every spreadsheet before it imports them?

Private Sub Command2_Click()
Dim strFile As String 'Filename
Dim strFileList() As String 'File Array
Dim intFile As Integer 'File Number
Dim filename As String
Dim path As String
DoCmd.SetWarnings False
path = "C:\Users\PSS700334\Desktop\3. EXCEL FILES\"

'Loop through the folder & build file list
strFile = Dir(path & "*.xls")

While strFile <> ""
'add files to the list
intFile = intFile + 1
ReDim Preserve strFileList(1 To intFile)
strFileList(intFile) = strFile
strFile = Dir()
Wend

'see if any files were found
If intFile = 0 Then
MsgBox "No files found"
Exit Sub
End If

'cycle through the list of files
For intFile = 1 To UBound(strFileList)
filename = path & strFileList(intFile)
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel8, "Check", filename, True
Next intFile
DoCmd.SetWarnings True

End Sub

 

[SydneyGeek]

If you want to avoid the headers, change the last parameter to False.

Denis