asked on

Access Add Excel File Name to Import Table

I'm using the following code to import an Excel file and I would like to add the Excel file name to the import table ,,,, tblReceiptIndex

Private Sub cmdImport_Click()
Dim oXL As Object
Dim wkb As Object
Dim wks As Object
Set oXL = CreateObject("excel.application")

On Error GoTo Err_Handler

      
              
Set wkb = oXL.Workbooks.Open(Me.txtFileName)

oXL.Quit
Set oXL = Nothing



DoCmd.SetWarnings False
If IsNull(Me.txtFileName) Or Len(Me.txtFileName & "") = 0 Then
    MsgBox "please select excel file"
    Me.cmdSelect.SetFocus
    Exit Sub
End If


'Delete records in the temp table
DoCmd.OpenQuery "qryDelReceiptsIndex"

DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, "tblReceiptIndex", Me.txtFileName, True

Open in new window

Private Sub cmdSelect_Click()

    Dim strStartDir As String
    
    Dim strFilter As String
    Dim lngFlags As Long
    
    ' Lets start the file browse from our current directory
     
    strStartDir = CurrentDb.Name
    strStartDir = Left(strStartDir, Len(strStartDir) - Len(Dir(strStartDir)))

    
    strFilter = ahtAddFilterItem(strFilter, _
                        "Excel Files (*.xls*)", "*.xls*")
    Me.txtFileName = ahtCommonFileOpenSave(InitialDir:=strStartDir, _
                     Filter:=strFilter, FilterIndex:=3, Flags:=lngFlags, _
                     DialogTitle:="Select File")
        

End Sub

Open in new window

PatHartman

This is way more than you need but rather than try to cut out the relevant parts and break the code, I'm including all of it. This code imports bank statements. It logs the file names as they are selected for import because it is critical that files are not imported more than once or out of order.

Private Sub cmdImport_Click()
    Dim db                  As DAO.Database
    Dim td                  As DAO.TableDef
    Dim rs                  As DAO.Recordset
    Dim strProcessed        As String
    Dim fs                  As Scripting.FileSystemObject
    Dim folder As Scripting.folder
    Dim file As Scripting.file
    Dim filefolder
    Dim ToFolderName        As String
    Dim CountBankInput      As Long
    Dim CountChecksBefore   As Long
    Dim CountChecksAfter    As Long
    Dim FileCounter         As Long
    Dim FileName            As String
    Dim LastImport          As Variant
    
    On Error GoTo Err_Proc

    If Me.txtFolder & "" = "" Then
        MsgBox "Please select a folder to import.", vbOKOnly
        Exit Sub
    End If
    
    Set db = CurrentDb()
    Set td = db.TableDefs!tblImportLog
    Set rs = td.OpenRecordset
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set folder = fs.GetFolder(Me.txtFolder)
    Set filefolder = folder.Files
    
    FileCounter = 0
    For Each file In filefolder
        If file.Type = "Microsoft Excel Worksheet" Then
            FileCounter = FileCounter + 1
            FileName = folder.Path
            If Right(FileName, 1) = "\" Then
                FileName = FileName & file.Name
            Else
                FileName = FileName & "\" & file.Name
            End If
            LastImport = DMax("SourceFileName", "tblImportLog")
            If file.Name > LastImport Or IsNull(LastImport) Then
            Else
                If file.Name = DLookup("SourceFileName", "tblImportLog", "SourceFileName = '" & file.Name & "'") Then
                    MsgBox "This file has already been imported.  Please remove it from the import folder and start again.", vbOKOnly
                    Exit Sub
                Else
                    MsgBox "This file name is from a prior period.  Please have the programmer validate the data before continuing.", vbOKOnly
                    Exit Sub
                End If
            End If
            Me.txtFile = FileName
            Me.Repaint
            rs.AddNew
                rs!sourcefilename = Mid(Me.txtFile, InStrRev(Me.txtFile, "\") + 1)
                rs!sourcepathname = Left(Me.txtFile, InStrRev(Me.txtFile, "\"))
                rs!ImportDT = Date
                Me.txtBatchID = rs!BatchID            'will not work with SQL Server

            GoSub FileProcess
                rs!RecCount = DCount("*", "tblBankInput", "SourceFileName = '" & file.Name & "'")
            
            rs.Update
        End If
    Next
    Me.Repaint
    
FileProcess:
    strProcessed = Replace(Me.txtFile, "\Output\", "\Processed\")
    ToFolderName = Left(strProcessed, InStrRev(strProcessed, "\"))

    
    DoCmd.RunMacro "mWarningsOff"
    CountBankInput = 0
    CountChecksBefore = 0
    CountChecksAfter = 0
'empty work tables
    DoCmd.OpenQuery "qDelSheet1"
'import spreadsheet
    DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, "Sheet1", Me.txtFile, False
'append to work table
    DoCmd.OpenQuery "qAppFirstColumns"
    DoCmd.OpenQuery "qAppSecondColumns"
    CountBankInput = DCount("*", "tblBankInput")
    CountChecksBefore = DCount("*", "tblChecks")
'append new items to final table
    DoCmd.OpenQuery "qAppChecks"
    CountChecksAfter = DCount("*", "tblChecks")
'update existing items in final table
    DoCmd.OpenQuery "qUpdChecks_CD1"
    DoCmd.OpenQuery "qUpdChecks_CD2"
    DoCmd.OpenQuery "qUpdChecks_CD3"
    DoCmd.OpenQuery "qUpdChecks_CD4"
    DoCmd.OpenQuery "qUpdChecks_CD5"
    DoCmd.OpenQuery "qUpdChecks_CDNone"

'verify that all data was appended before moving import file to processed folder
'''    If CountBankInput = CountChecksAfter - CountChecksBefore Then       'Make sure all checks got appended
'''        DoCmd.RunSQL "UPDATE tblImportLog SET tblImportLog.RecCount = " & CountBankInput & " WHERE tblImportLog.BatchID = " & Me.txtBatchID & ";"
        fs.CopyFile Source:=Me.txtFile, Destination:=ToFolderName
        Kill Me.txtFile
        ''MsgBox "Complete", vbOKOnly
'''    Else
'''        DoCmd.RunSQL "Delete * From tblChecks Where BatchID = " & Me.txtBatchID
'''        DoCmd.RunSQL "UPDATE tblImportLog SET tblImportLog.DeletedFlg = True WHERE BatchID = " & Me.txtBatchID
'''        MsgBox CountChecksAfter - CountChecksBefore & " Records did not get added.  Please fix spreadsheet.", vbOKOnly
'''        GoTo Exit_Proc
'''    End If
    Return
    
Exit_Proc:
    DoCmd.RunMacro "mWarningsOn"
    MsgBox "Complete " & FileCounter & " files imported.", vbOKOnly
    Exit Sub
Err_Proc:
    Select Case Err.Number
        Case Else
            MsgBox Err.Number & "--" & Err.Description
            Resume Exit_Proc
            Resume
    End Select
End Sub

Open in new window

ASKER CERTIFIED SOLUTION

John Tsioumpris

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

shieldsco

ASKER

Thanks