Как добавить имя файла при импорте нескольких файлов Excel в одну таблицу Access

Question

Я использую 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 

Answer 1

код проще и run- производительность времени должно быть намного лучше, если вы исключите Recordset. вы можете выполнить UPDATE после каждого TransferSpreadsheet

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