将多个Excel文件导入一个Access表时如何添加文件名

Posted 2023-05-07

【中文标题】将多个Excel文件导入一个Access表时如何添加文件名

【英文标题】：How to add file name when importing multiple Excel files to one Access table

【发布时间】：2016-06-16 14:16:41

【问题描述】：

我正在使用 Access VBA 将多个 Excel 文件导入我的 Access 数据库。这将是一个每月处理 20-50 个文件和 10-60K 记录的过程。我需要包含一个不包含在电子表格文件本身中但在其文件名中的“应用程序名称”。我不想手动将应用程序名称添加到 Excel 文件中，而是希望通过我的 VBA 代码添加它。

我不精通 Access，并且通过搜索如何完成将大部分内容拼凑在一起。这“有效”，但是当我在更大的批次上运行它时，我收到一个错误“运行时错误'3035'：超出系统资源。'当我删除添加文件名（循环记录）的部分时，它运行良好。我认为这是因为这些步骤没有有效地排序？任何帮助将不胜感激。

 Public Function Import_System_Access_Reports()

 Dim strFolder As String
 Dim db As DAO.Database
 Dim tdf As DAO.TableDef
 Dim fld As DAO.Field
 Dim rstTable As DAO.Recordset
 Dim strFile As String
 Dim strTable As String
 Dim lngPos As Long
 Dim strExtension As String
 Dim lngFileType As Long
 Dim strSQL As String
 Dim strFullFileName As String

 With Application.FileDialog(4) ' msoFileDialogFolderPicker
     If .Show Then
         strFolder = .SelectedItems(1)
     Else
         MsgBox "No folder specified!", vbCritical
         Exit Function
     End If
 End With
 If Right(strFolder, 1) <> "\" Then
     strFolder = strFolder & "\"
 End If
 strFile = Dir(strFolder & "*.xls*")
 Do While strFile <> ""

     lngPos = InStrRev(strFile, ".")
     strTable = "RawData"
     'MsgBox "table is:" & strTable
     strExtension = Mid(strFile, lngPos + 1)
     Select Case strExtension
         Case "xls"
             lngFileType = acSpreadsheetTypeExcel9
         Case "xlsx", "xlsm"
             lngFileType = acSpreadsheetTypeExcel12Xml
         Case "xlsb"
             lngFileType = acSpreadsheetTypeExcel12
     End Select
    DoCmd.TransferSpreadsheet _
         TransferType:=acImport, _
         SpreadsheetType:=lngFileType, _
         TableName:=strTable, _
         FileName:=strFolder & strFile, _
         HasFieldNames:=True ' or False if no headers

'Add and populate the new field
 'set the full file name
 strFullFileName = strFolder & strFile

'Initialize
 Set db = CurrentDb()
 Set tdf = db.TableDefs(strTable)

 'Add the field to the table.
 'tdf.Fields.Append tdf.CreateField("FileName", dbText, 255)

 'Create Recordset
 Set rstTable = db.OpenRecordset(strTable)
 rstTable.MoveFirst

 'Loop records
 Do Until rstTable.EOF
 If (IsNull(rstTable("FileName")) Or rstTable("FileName") = "") Then
     rstTable.Edit
     rstTable("FileName") = strFile
     rstTable.Update
     End If
     rstTable.MoveNext
 Loop

     strFile = Dir

 'Move to the next file
 Loop
     'Clean up
     Set fld = Nothing
     Set tdf = Nothing
     Set db = Nothing
     'rstTable.Close
     Set rstTable = Nothing

End Function

【参考方案1】：

如果去掉Recordset，代码会更简单，运行时性能会更好。您可以在每个TransferSpreadsheet 之后执行UPDATE

Dim strFolder As String
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim strFile As String
Dim strTable As String
Dim strExtension As String
Dim lngFileType As Long
Dim strSQL As String
Dim strFullFileName As String
Dim varPieces As Variant

' --------------------------------------------------------
'* I left out the part where the user selects strFolder *'
' --------------------------------------------------------

strTable = "RawData" '<- this could be a constant instead of a variable
Set db = CurrentDb()
' make the UPDATE a parameter query ...
strSQL = "UPDATE [" & strTable & "] SET FileName=[pFileName]" & vbCrLf & _
    "WHERE FileName Is Null OR FileName='';"
Set qdf = db.CreateQueryDef(vbNullString, strSQL)

strFile = Dir(strFolder & "*.xls*")
Do While Len(strFile) > 0
    varPieces = Split(strFile, ".")
    strExtension = varPieces(UBound(varPieces))
    Select Case strExtension
    Case "xls"
        lngFileType = acSpreadsheetTypeExcel9
    Case "xlsx", "xlsm"
        lngFileType = acSpreadsheetTypeExcel12Xml
    Case "xlsb"
        lngFileType = acSpreadsheetTypeExcel12
    End Select
    strFullFileName = strFolder & strFile
    DoCmd.TransferSpreadsheet _
            TransferType:=acImport, _
            SpreadsheetType:=lngFileType, _
            TableName:=strTable, _
            FileName:=strFullFileName, _
            HasFieldNames:=True ' or False if no headers

    ' supply the parameter value for the UPDATE and execute it ...        
    qdf.Parameters("pFileName").Value = strFile
    qdf.Execute dbFailOnError

    'Move to the next file
    strFile = Dir
Loop