Excel VBA質問箱 IV

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

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


12435 / 13645 ツリー ←次へ | 前へ→

【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 お礼

【10434】MDBから情報を得たい・・・。
質問  大雪男  - 04/1/26(月) 16:54 -

引用なし
パスワード
   こんにちは。

エクセルから、MDBの中に存在する全てのテーブルの名前を
シートに取り込んでくる事は可能でしょうか?

また、テーブルのデータをエクセルにインポートする事は出来ますか?

宜しくお願いします。

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

引用なし
パスワード
   >また、テーブルのデータをエクセルにインポートする事は出来ますか?
データ 外部データの取込 で出来ませんか?

【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を実行して確認してみて下さい。

【10442】Re:MDBから情報を得たい・・・。
お礼  大雪男  - 04/1/27(火) 8:44 -

引用なし
パスワード
   ichinoseさん、INAさん、おはようございます。

ありがとうございます。
ichinoseさんの記述で取り込み出来ました。
感動でございます!

まだ、???ってなところがたくさんあるので
勉強させて頂きます。

本当にありがとうございます。

【10494】OLEオブジェクト型?
質問  大雪男  - 04/1/29(木) 14:14 -

引用なし
パスワード
   再び、教えて下さい。

ichinoseさんの記述で殆ど旨くいきますが、一部取り込めない
テーブルがでてきてしまいました。

テーブルは3つのフィールドから出来ており、データ型が
1.テキスト型
2.テキスト型
3.OLEオブジェクト型
となっています。

このテーブルは5レコードあるのですが、最初の1レコードのみ
を取り込んで、2レコード以後がありません。

OLEオブジェクト型のフィールドがあると取り込めないのでしょうか?
OLEオブジェクト型のフィールドは無しとしてでも、全てのレコードを
読み込む事は可能でしょうか?

どうか宜しくお願いします。

【10504】Re:OLEオブジェクト型?
回答  ichinose  - 04/1/29(木) 20:22 -

引用なし
パスワード
   ▼大雪男 さん:
こんばんは。再送です(さっき、投稿したコードにちょっとしたバグがあったもので)。

>
>テーブルは3つのフィールドから出来ており、データ型が
>1.テキスト型
>2.テキスト型
>3.OLEオブジェクト型
>となっています。
>
>このテーブルは5レコードあるのですが、最初の1レコードのみ
>を取り込んで、2レコード以後がありません。
>OLEオブジェクト型のフィールドがあると取り込めないのでしょうか?
前回のコードは、OLEオブジェクト型を想定していませんでした。
OLEオブジェクト型のI/Oは、バイナリデータしかやったことがありません。
中のデータは色々ありますからねえ・・・。

>OLEオブジェクト型のフィールドは無しとしてでも、全てのレコードを
>読み込む事は可能でしょうか?
↑これを可能に改造してみました。
とりあえず、変更のないプロシジャーも全部載せますね!!
まず、標準モジュール(Modile1)に
'===============================================================
Sub main()
  Dim tblnm
  Dim fldlist
  Dim mysql As String
  If open_cat("D:\EXCELファイル\import.mdb") = 0 Then
   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)
      If chk_tbl(tblnm(idx), fldlist, mysql) = 0 Then
'        ↑ここで、フィールド名一覧取得とフィールドチェックとSqlを作成
        With Worksheets(idx)
         .Range("a1").Value = tblnm(idx)
         .Range(.Cells(2, 1), .Cells(2, UBound(fldlist))).Value = fldlist
         Call copy_rs(.Range("a3"), mysql)
         End With
      Else
        Exit For
        End If
      Next
     End If
   End If
  Call close_cat
End Sub

'標準モジュール(Module2)に
'===============================================================
Private cat As ADOX.Catalog
'===============================================================
Function open_cat(flnm As String) As Long
  On Error Resume Next
  Set cat = New ADOX.Catalog
  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 chk_tbl(tblnm, fldnm, mysql As String)
'指定されたテーブルのフィールドのチェックとSqlの作成
  On Error GoTo err_chk_tbl
  Dim nmlist()
  Dim sql() As String
  Dim err_flg As Boolean
  Dim rs As ADODB.Recordset
  chk_tbl = 0
  err_flg = False
  Set rs = New ADODB.Recordset
  With rs
   .Open "select * from " & tblnm, cat.ActiveConnection, adOpenDynamic, adLockPessimistic
   For idx = 0 To .Fields.Count - 1
    ReDim Preserve nmlist(1 To idx + 1)
    ReDim Preserve sql(1 To idx + 1)
    nmlist(idx + 1) = .Fields(idx).Name
    If .Fields(idx).Type = adChapter Or .Fields(idx).Type = adLongVarBinary Then
      sql(idx + 1) = """"" as f" & idx + 1
      err_flg = True
    Else
      sql(idx + 1) = .Fields(idx).Name
      End If
    Next
   .Close
   End With
  fldnm = nmlist()
  If err_flg = False Then
   mysql = "select * from " & tblnm
  Else
   mysql = "select " & Join(sql(), ",") & " from " & tblnm
   End If
ret_chk_tbl:
  Set rs = Nothing
  On Error GoTo 0
  Exit Function
err_chk_tbl:
  MsgBox Error(Err.Number)
  chk_tbl = Err.Number
  Resume ret_chk_tbl
End Function
'===============================================================
Function copy_rs(rng As Range, sql_str) As Long
'データのコピー
  Dim rs As ADODB.Recordset
  copy_rs = 0
  Set rs = New ADODB.Recordset
  On Error GoTo err_copy_rs
  rs.Open sql_str, cat.ActiveConnection, adOpenDynamic, adLockPessimistic
  rng.CopyFromRecordset rs
  rs.Close
ret_copy_rs:
  On Error GoTo 0
  Exit Function
err_copy_rs:
  MsgBox Error(Err.Number) & sql_str
  copy_rs = Err.Number
  Resume ret_copy_rs
End Function
'===============================================================
Sub close_cat()
  cat.ActiveConnection.Close
  Set cat = Nothing
End Sub

コードを差し替えて確認をお願いします。

【10511】Re:OLEオブジェクト型?
お礼  大雪男  - 04/1/30(金) 11:53 -

引用なし
パスワード
   ichinose さん、こんにちは。

この度もありがとうございます。
バッチリ取り込めました。

初回に教えて頂いたものと比較しながら勉強します。
頭から煙が出そうですが・・・頑張ります。

本当にありがとうございました。

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