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

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

我不熟练使用Access，并通过关于如何完成的search将大部分内容拼凑在一起。 这个“工作”，但是当我在大批量运行时，我收到错误“运行时错误3035”：超出系统资源。 当我删除添加文件名（循环logging）的部分，它运行良好。我认为这是因为步骤没有有效地sorting？任何帮助，将不胜感激。

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 

Answer 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