하나의 액세스 테이블에 여러 Excel 파일을 가져올 때 파일 이름을 추가하는 방법

Question

Access 데이터베이스를 사용하여 여러 Excel 파일을 가져 오려고합니다. 이것은 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을 제거하면 시간 성능이 훨씬 더해야합니다. 당신은 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