| |
大雪男 さん、INAさん、こんばんは。
>エクセルから、ＭＤＢの中に存在する全てのテーブルの名前を
>シートに取り込んでくる事は可能でしょうか？
>
>また、テーブルのデータをエクセルにインポートする事は出来ますか？
以下のコードの仕様は、最左端シートから、
セルA1----テーブル名
2行目のＡ列から---フィールド名
3行目のＡ列から---インポートデータ
と設定します。
上記データがテーブル毎に別シートにテーブルの数だけ書き込まれます。
尚、参照設定として「Microsoft ActiveX Data Objects 2.x Library」、
及び、「Microsoft ADO Ext 2.X for DDL and Security」にチェックして下さい。
標準モジュール（Module1）に、
'===============================================================
Sub main()
Dim tblnm
If open_cat("D:\EXCELファイル\Import.mdb") = 0 Then
'↑目的のmdbファイルのフルパス
tblnm = get_tblnm 'テーブル名を取得
If VarType(tblnm) <> vbBoolean Then 'テーブルがあれば？
For idx = 1 To UBound(tblnm) - 1
Worksheets.Add after:=Worksheets(idx)
Next
For idx = LBound(tblnm) To UBound(tblnm)
Worksheets(idx).Range("a1").Value = tblnm(idx)
Call copy_rs(Worksheets(idx).Range("a2"), "select * from " & tblnm(idx))
Next
End If
End If
Call close_cat
End Sub
標準モジュール（Module2）に、
'===============================================================
Private cat As New ADOX.Catalog
Function open_cat(flnm As String) As Long
On Error Resume Next
cat.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & flnm
open_cat = Err.Number
On Error GoTo 0
End Function
'======================================================================
Function get_tblnm()
Dim mytbl()
Dim tbl As ADOX.Table
idx = 1
For Each tbl In cat.Tables
If UCase(tbl.Type) = UCase("table") Then
ReDim Preserve mytbl(1 To idx)
mytbl(idx) = tbl.Name
idx = idx + 1
End If
Next
If idx > 1 Then
get_tblnm = mytbl()
Else
get_tblnm = False
End If
End Function
'==================================================================
Function copy_rs(rng As Range, sql) As Long
Dim rs As ADODB.Recordset
copy_rs = 0
Set rs = New ADODB.Recordset
On Error GoTo err_copy_rs
rs.Open sql, cat.ActiveConnection, adOpenDynamic, adLockPessimistic
For idx = 1 To rs.Fields.Count
With rng
.Offset(0, idx - 1).Value = rs.Fields(idx - 1).Name
End With
Next
rng.Offset(1, 0).CopyFromRecordset rs
rs.Close
ret_copy_rs:
On Error GoTo 0
Exit Function
err_copy_rs:
copy_rs = Err.Number
Resume ret_copy_rs
End Function
'=======================================================================
Sub close_cat()
Set cat = Nothing
End Sub
これで、プロシジャーmainを実行して確認してみて下さい。
|
|
ichinose
- 04/1/26(月) 19:29 -
