Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


70796 / 76733 ←次へ | 前へ→

【10439】Re:MDBから情報を得たい・・・。
回答  ichinose  - 04/1/26(月) 19:29 -

引用なし
パスワード
   大雪男 さん、INAさん、こんばんは。

>エクセルから、MDBの中に存在する全てのテーブルの名前を
>シートに取り込んでくる事は可能でしょうか?
>
>また、テーブルのデータをエクセルにインポートする事は出来ますか?

以下のコードの仕様は、最左端シートから、
セルA1----テーブル名
2行目のA列から---フィールド名
3行目のA列から---インポートデータ
と設定します。
上記データがテーブル毎に別シートにテーブルの数だけ書き込まれます。

尚、参照設定として「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を実行して確認してみて下さい。
1 hits

【10434】MDBから情報を得たい・・・。 大雪男 04/1/26(月) 16:54 質問
【10435】Re:MDBから情報を得たい・・・。 INA 04/1/26(月) 17:19 回答
【10439】Re:MDBから情報を得たい・・・。 ichinose 04/1/26(月) 19:29 回答
【10442】Re:MDBから情報を得たい・・・。 大雪男 04/1/27(火) 8:44 お礼
【10494】OLEオブジェクト型? 大雪男 04/1/29(木) 14:14 質問
【10504】Re:OLEオブジェクト型? ichinose 04/1/29(木) 20:22 回答
【10511】Re:OLEオブジェクト型? 大雪男 04/1/30(金) 11:53 お礼

70796 / 76733 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free