access vba エクセル取り込み
Function GetXlData(InPath, InFile) As Boolean
' パス＆ファイル名のエクセルデータを丸ごと読み込んで
' データ変換後 Access に取り込む。 GetObject() 使用。
' Access側の既にあるテーブルに全て文字列フィールドとして格納。
' 参照設定：Microsoft DAO x.x Object Library 必須
If IsNull(InPath) Then
MsgBox "エクセルファイルのパスが未入力です。", vbOKOnly
Exit Function
End If
If IsNull(InFile) Then
MsgBox "エクセルファイルのファイル名が未入力です。", vbOKOnly
Exit Function
End If
' Excel用の宣言
Dim MyXl As Object
Dim myData As Variant
Dim r As Integer, c As Integer ' 行数、列数
Dim rcnt As Integer, ccnt As Integer
' Access用の宣言
Dim mdb As DAO.Database
Dim rst As DAO.Recordset
Dim rtn As String ' フルパス
Const tmpTbl = "In_xlData" ' 仮テーブル
Dim newTbl As String ' コピーテーブル
newTbl = Replace(InFile, ".xls", "")
'Accessダイアログ非表示
DoCmd.SetWarnings False
'テーブルの削除
If isExistTable(newTbl) Then
DoCmd.DeleteObject acTable, newTbl
End If
'テーブルのコピー
DoCmd.CopyObject , newTbl, acTable, "In_xlData"
rtn = InPath & InFile
On Error Resume Next
' 既にExcelが起動済みでなければエラー
Set MyXl = GetObject(, "Excel.Application")
If Err.Number <> 0 Then Err.Clear ' Errをクリア
On Error GoTo Err_GetXlData
' 読込開始
Set MyXl = GetObject(rtn)
MyXl.Worksheets(3).Activate
'3 シート目ヘッダー行あり
myData = MyXl.Worksheets(3).Range("A2").CurrentRegion.Value
r = UBound(myData, 1) ' 行数
c = UBound(myData, 2) ' 列数
' Excel 終了
MyXl.Application.Quit
' 変数開放
Set MyXl = Nothing
' Accessに読込
Set mdb = CurrentDb
Set rst = mdb.OpenRecordset(newTbl)
If Not rst.EOF Then
' 仮テーブル内の全データ削除
mdb.Execute "DELETE * FROM " & newTbl & ";"
End If
' ExcelDataの値を仮テーブルに格納
For rcnt = 2 To r ' field名以外の、行番号
rst.AddNew
For ccnt = 1 To c ' 列
rst(ccnt - 1).Value = myData(rcnt, ccnt)
Next ccnt
rst.Update
Next rcnt
' 変数開放
Set rst = Nothing: Set mdb = Nothing
GetXlData = True '全て完了(文字列無事格納)
exit_GetXlData:
Exit Function
Err_GetXlData:
MsgBox Err.Description
Resume exit_GetXlData
End Function
http://www.nurs.or.jp/~ppoy/access/access/acM002.html
