VBAでテーブルを一括削除して、テーブルを作成する方法
Function GetXlData() As Boolean
' パス＆ファイル名のエクセルデータを丸ごと読み込んで
' データ変換後 Access に取り込む。 GetObject() 使用。
' Access側の既にあるテーブルに全て文字列フィールドとして格納。
' 参照設定：Microsoft DAO x.x Object Library 必須
Dim InPath As String
InPath = CurrentProject.Path
Dim InFile As String
InFile = "○○.xls"
' 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 ' フルパス
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(1).Activate
myData = MyXl.Worksheets(1).Range("A1:C10").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("SELECT [Name] FROM MSysObjects WHERE ([Name] Not Like 'MSys*') AND ([Type]=1) AND ([Flags]=0);", dbOpenForwardOnly)
Do Until rst.EOF Or rst.BOF
TList = TList & ",[" & rst!Name & "]"
rst.MoveNext
Loop
If rst.RecordCount > 0 Then
mdb.Execute "DROP TABLE " & Mid$(TList, 2) & ";"
End If
rst.Close
' ExcelDataの値を仮テーブルに格納
For rcnt = 2 To r ' field名以外の、行番号
If Trim(myData(rcnt, 1) & "") <> "" Then
If rcnt > 2 Then
rst.Close
End If
createTable (Trim(myData(rcnt, 1) & ""))
Set rst = mdb.OpenRecordset(Trim(myData(rcnt, 1) & ""))
End If
rst.AddNew
For ccnt = 2 To c ' 列
If ccnt = c And myData(rcnt, ccnt) & "" = "" Then
'『内容』のフィールドが空の時は無視
Else
rst(ccnt - 2).Value = myData(rcnt, ccnt) & ""
End If
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
Function createTable(sTableName As String)
On Error GoTo Errorhandle
Dim dbsCurrent As Database
Dim tdfNew As TableDef
Dim fldLoop As Field
Dim prpLoop As Property
Dim strNewTableName As String
Dim strmsg As String
Dim strFieldName As String
'■Dim varInputBox As Variant
'■varInputBox = InputBox("新規作成するテーブル名を入力して下さい。")
'■空白（""）の場合は、以降の処理を中止。
'■If varInputBox = "" Then MsgBox "空白はダメ。再度トライして下さい。", 16, "管理者": End
'■strNewTableName = varInputBox
strNewTableName = sTableName '新規作成するテーブル名。
strmsg = "新規テーブル 「" & strNewTableName & "」 を作成しますか？"
'If 1 = MsgBox(strmsg, 17, "Microsoft Access Club") Then
Set dbsCurrent = OpenDatabase(CurrentDb.Name)
'新しい TableDef オブジェクトを作成します。
Set tdfNew = dbsCurrent.CreateTableDef(strNewTableName)
With tdfNew
' フィールドを作成し、新しい TableDef オブジェクトに追加します。
' これは、TableDef オブジェクトを このデータベース上の
'TableDefs コレクションに追加する前に行う必要があります。
.Fields.Append .CreateField("コード", dbText, 40)
.Fields.Append .CreateField("内容", dbText, 255)
' 新しい TableDef オブジェクトをデータベースに追加します｡
dbsCurrent.TableDefs.Append tdfNew
End With
For Each fldLoop In tdfNew.Fields
strFieldName = strFieldName & Chr(13) & "●" & fldLoop.Name & _
" , " & FieldTypeCK(fldLoop.Type) & _
" , " & IIf(fldLoop.Size = 0, "--", "Size: " & fldLoop.Size)
Next fldLoop
dbsCurrent.Close '開放します。
'MsgBox "「" & strNewTableName & "」テーブルの作成が完了いたしました。" & Chr(13) & _
"フィールドの構成は、下記のとおりです。" & Chr(13) & strFieldName, , "管理者"
'End If
Exit Function
Errorhandle:
'エラーコード3010は、同名オブジェクトがあり次の作業ができないときのメッセージです。
If Err.Number = 3010 Then
If 1 = MsgBox("同名のテーブル【" & sTableName & "】があります。" & Chr(13) & _
"同名のテーブルがあると、テーブルの新規作成ができません。" & Chr(13) & _
"これを削除しますか？", 17, "管理者") Then
'既に同名のテーブルがある場合は、テーブルを削除します。
dbsCurrent.TableDefs.Delete strNewTableName
Resume 'エラーの発生箇所に戻ります。
Else
MsgBox "同名のテーブルがあると、テーブルの新規ができません。" & Chr(13) & _
"テーブル名の変更を行って下さい。" & Chr(13) & _
"今回のテーブル作成処理を中止いたします。", 16, "管理者"
End If
Else
MsgBox "予期せぬエラーが発生しました。" & Chr(13) & _
"エラーナンバー：" & Err.Number & Chr(13) & _
"エラー内容：" & Err.Description, vbOKOnly, "管理者"
End If
End Function
Function QueryTypeCK(Qtype As Integer)
Select Case Qtype
Case dbQSelect: QueryTypeCK = "選択クエリ"
Case dbQAction: QueryTypeCK = "アクションクエリ"
Case dbQCrosstab: QueryTypeCK = "クロス集計クエリ"
Case dbQUpdate: QueryTypeCK = "更新クエリ"
Case dbQAppend: QueryTypeCK = "追加クエリ"
Case dbQDelete: QueryTypeCK = "削除クエリ"
Case dbQMakeTable: QueryTypeCK = "テーブル作成クエリ"
Case dbQDDL: QueryTypeCK = "データ定義クエリ"
Case dbQSQLPassThrough: QueryTypeCK = "パススルークエリ"
Case dbQSetOperation: QueryTypeCK = "ユニオンクエリ"
Case Else: QueryTypeCK = "不明"
End Select
End Function
Function FieldTypeCK(intType As Integer) As String
Select Case intType
Case dbBoolean: FieldTypeCK = "ブール型"
Case dbByte: FieldTypeCK = "バイト型"
Case dbInteger: FieldTypeCK = "整数型"
Case dbLong: FieldTypeCK = "長整数型"
Case dbCurrency: FieldTypeCK = "通貨型"
Case dbSingle: FieldTypeCK = "単精度浮動小数点数型"
Case dbDouble: FieldTypeCK = "倍精度浮動小数点数型"
Case dbDate: FieldTypeCK = "日付/時刻型"
Case dbText: FieldTypeCK = "テキスト型"
Case dbBinary: FieldTypeCK = "バイナリ型"
Case dbMemo: FieldTypeCK = "メモ型"
Case dbGUID: FieldTypeCK = "GUID型"
Case Else: FieldTypeCK = "不明"
End Select
End Function
http://www.accessclub.jp/samplefile/samplefile_163.htm
