複数のExcelファイルを1つのアクセステーブルにインポートするときにファイル名を追加する方法

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

コードは単純でランですあなたが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