Excel入力シートをガッツリAccessに取込

極力汎用的な作りに

Option Compare Database

Const sDataSheetName As String = "sheet1" 'データ取得シート名
Const sDataSheetRow As Long = 2           'データ取得行
Const sTableName As String = "T_Test"     'データ格納先テーブル名

'個々のExcel入力シートを取り込む関数
'取り込んだ結果を文字列形式で返す
Public Function ImportExcelFile(sFileName As String) As String
  On Error GoTo Err_Trap
  Dim xl As Object
  Dim wb As Object
  Dim ws As Object
  Dim buf As Variant
  Dim db As DAO.Database
  Dim rs As DAO.Recordset
  Dim i As Long
  Dim sErr As String
  
  If sFileName = "" Then Exit Function
  
  If Dir(sFileName) = "" Then
    ImportExcelFile = "×" & sFileName & "(ファイルがありません。)"
    Exit Function
  End If
  
  Set xl = CreateObject("Excel.Application")

  Set wb = xl.Workbooks.Open(sFileName)
  Set ws = wb.Worksheets(sDataSheetName)
  buf = ws.Rows(sDataSheetRow)
  wb.Close (False)
  xl.Quit
  Set db = CurrentDb
  Set rs = db.OpenRecordset(sTableName)
  sErr = ""
  On Error GoTo Err_WriteTable
  rs.AddNew
  For i = 0 To rs.Fields.Count - 1
    rs.Fields(i) = buf(1, i + 1)
  Next i
  On Error GoTo Err_Trap
  rs.Update
  
  ImportExcelFile = "○" & sFileName & IIf(sErr <> "", "(" & sErr & ")", "")
  
  Exit Function
  
Err_WriteTable:
  If sErr <> "" Then sErr = sErr & "/"
  sErr = sErr & rs.Fields(i).Name & "->" & Err.Number & ":" & Err.Description
  Resume Next
  
Err_Trap:
  ImportExcelFile = "×(" & Err.Number & Err.Description & ")"
  
End Function

'任意のフォルダ内のExcelファイルを一括で取り込むための処理
'サブフォルダも再帰的に探索

Public Sub getExcelData(sPath As String)
    Dim buf As String
    Dim f As Object
    Dim sRet As String 'ファイル取込処理の結果を一時格納
    If sPath = "" Then Exit Sub
    If Right(sPath, 1) = "\" Then sPath = Left(sPath, Len(sPath) - 1)
    On Error GoTo Err_Dir
    buf = Dir(sPath & "\*.xls*")
    On Error GoTo 0
    Do Until buf = ""
      sRet = ImportExcelFile(sPath & "\" & buf)
      If Left(sRet, 1) = "○" Then nSuccess = nSuccess + 1
      nFile = nFile + 1
      Call ShowLog(sRet)
      buf = Dir()
    Loop
    
    With CreateObject("Scripting.FileSystemObject")
      For Each f In .GetFolder(sPath).SubFolders
        Call getExcelData(f.Path)
      Next f
    
    End With
    
    Exit Sub
Err_Dir:
  Select Case Err.Number
    Case 52
      Call ShowLog(sPath & "にはアクセスできません。")
      Call ShowLog("アクセスできないフォルダを含まない範囲で検索先フォルダを指定してください。")
      Exit Sub
    Case Else
      Debug.Print Err.Number & ":" & Err.Description
      Stop
  End Select
    
End Sub