[[20100811153656]]　『アクセスデータ』（TM）　ページの最後に飛ぶ

『アクセスデータ』（TM）

 Excel2007 WindowsXP

 開いているAAA.xlsデータと同じフォルダ内の、
 BBB.MDBデータの
 CCC:テーブルをAAA.xlsのSheet1
 DDD:テーブルをAAA.xlsのSheet2

 に全選択して貼り付けるマクロを教えてください。

こんにちは

外部データの取り込みをマクロに記録してみてはどうですか？

そのコードを整理すればいいです。

（ウッシ）

 ウッシさん、回答ありがとうございます。

 マクロ記録してみました。

 Sub TEST()

    With ActiveSheet.ListObjects.Add(SourceType:=0, Source:=Array( _
        "OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;Password="""";User  ID=Admin;Data Source=ここがアクセスデータの保存先;Mode=Share Deny  Write;Extended Properti" _
        , _
        "es="""";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Jet OLEDB:Engine Type=5;Jet OLEDB:D" _
        , _
        "atabase Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New Database Password=" _
        , _
        """"";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt  Database=False;Jet OLEDB:Don't Copy Locale on Compact=False;Jet OLED" _
        , _
        "B:Compact Without Replica Repair=False;Jet OLEDB:SFP=False;Jet    OLEDB:Support Complex Data=False" _
        ), Destination:=Range("Sheet1!$A$1")).QueryTable
        .CommandType = xlCmdTable
        .CommandText = Array("ここがテーブルの名前")
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .SourceDataFile = "ここがアクセスデータの保存先"
        .ListObject.DisplayName = "テーブル_ここがアクセスデータの名前_1"
        .Refresh BackgroundQuery:=False
    End With
 End Sub

 わからない点がありまして、、、教えていただけたらと思います。

 1、データを取りにいくアクセスデータのファイル先ファイル名を指定ではなく、
 開いているEXCELデータがあるフォルダ内で、ファイル名指定という条件にしたいのです。

 2、アクセスデータの貼り付け先ですが、=Range("Sheet1!$A$1")で表現していると思うのですが、Sheet1以外のシートがアクティブになっている場合、エラーが出ました。
 別のシートでマクロ実行してもエラーが出ない方法が知りたいです。

こんばんは

これで出来るでしょうか？

 Sub TEST_1()
    Dim FileName  As Variant
    Dim Sh1       As Worksheet

    ChDir ThisWorkbook.Path
    FileName = Application.GetOpenFilename("MDB ファイル (*.mdb),*.mdb")
    If VarType(FileName) = vbBoolean Then Exit Sub

    Set Sh1 = Worksheets("Sheet1")

    With Sh1.ListObjects.Add(SourceType:=0, Source:=Array( _
        "OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;Password="""";User  ID=Admin;Data Source=FileName;Mode=Share Deny  Write;Extended Properti" _
        , _
        "es="""";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Jet OLEDB:Engine Type=5;Jet OLEDB:D" _
        , _
        "atabase Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New Database Password=" _
        , _
        """"";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt  Database=False;Jet OLEDB:Don't Copy Locale on Compact=False;Jet OLED" _
        , _
        "B:Compact Without Replica Repair=False;Jet OLEDB:SFP=False;Jet    OLEDB:Support Complex Data=False" _
        ), Destination:=Sh1.Range("A1")).QueryTable
        .CommandType = xlCmdTable
        .CommandText = Array("ccc")    '("ここがテーブルの名前")
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .SourceDataFile = FileName
        .ListObject.DisplayName = "テーブル_" & Replace(Mid(FileName, InStrRev(FileName, "\") + 1), ".mdb", "") 'bbb.mdb "テーブル_ここがアクセスデータの名前_1"
        .Refresh BackgroundQuery:=False
    End With
 End Sub

（ウッシ）

 ウッシさん回答ありがとうございます。
 マクロ実行してみたのですが、
 実行時エラー'1004':
 データソースの初期化に失敗しました。
 と出ました。
 すいません、原因全くわかりません。
 どこが悪いのでしょうか？
 (TM)

こんばんは

FileName の設定部分間違えてました。

あとはアクティブシートにしか設定出来ないという事と、既にクエリーテーブルが設定

されてた場合は削除しないとダメみたいです。

一旦設定したらテーブルのデータ更新は手作業でもいいような気もします。

 Sub Macro1()
    Dim FileName  As Variant
    Dim Sh1       As Worksheet

    ChDir ThisWorkbook.Path
    FileName = Application.GetOpenFilename("MDB ファイル (*.mdb),*.mdb")
    If VarType(FileName) = vbBoolean Then Exit Sub

    Set Sh1 = Worksheets("Sheet1")
    Sh1.Cells.Delete
    On Error Resume Next
    Sh1.Range("A1").ListObject.ListColumns(1).Delete
    On Error GoTo 0
    Application.Goto Sh1.Range("A1")

    With Sh1.ListObjects.Add(SourceType:=0, Source:=Array( _
        "OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;Password="""";User ID=Admin;Data Source=" & FileName & ";Mode=Share Deny Write;Extended Pr" _
        , _
        "operties="""";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Jet OLEDB:Engine Type=5;Jet O" _
        , _
        "LEDB:Database Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New Database Pas" _
        , _
        "sword="""";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on Compact=False;Je" _
        , _
        "t OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False;Jet OLEDB:Support Complex Data=False" _
        ), Destination:=Range("$A$1")).QueryTable
        .CommandType = xlCmdTable
        .CommandText = Array("ccc")
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .SourceDataFile = FileName
        .ListObject.DisplayName = "テーブル_" & Replace(Mid(FileName, InStrRev(FileName, "\") + 1), ".mdb", "") & "_1" 'bbb.mdb "テーブル_ここがアクセスデータの名前_1"
        .Refresh BackgroundQuery:=False
    End With
End Sub

（ウッシ）

 ウッシさん回答ありがとうございます。
 実行できました。

 >あとはアクティブシートにしか設定出来ないという事と、
 Sheet2をアクティブにしていたのですが、Sheet1に実行できました。

 その他にわからないところがあります。よろしければ教えてください。
 この作っていただいたマクロで
 CCC:テーブルをAAA.xlsのSheet1に貼り付けできましたが、
 同じ条件で
 DDD:テーブルをAAA.xlsのSheet2に貼り付けするマクロを盛り込むにはどうすればいいでしょうか？何回もすいません。
 (TM)

こんばんは

こんな感じでしょうか？

 Sub Macro2()
    Dim FileName  As Variant
    Dim Sh1       As Worksheet

    ChDir ThisWorkbook.Path
    FileName = Application.GetOpenFilename("MDB ファイル (*.mdb),*.mdb")
    If VarType(FileName) = vbBoolean Then Exit Sub

    Set Sh1 = Worksheets("Sheet2")
    Sh1.Cells.Delete
    On Error Resume Next
    Sh1.Range("A1").ListObject.ListColumns(1).Delete
    On Error GoTo 0
    Application.Goto Sh1.Range("A1")

    With Sh1.ListObjects.Add(SourceType:=0, Source:=Array( _
        "OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;Password="""";User ID=Admin;Data Source=" & FileName & ";Mode=Share Deny Write;Extended Pr" _
        , _
        "operties="""";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Jet OLEDB:Engine Type=5;Jet O" _
        , _
        "LEDB:Database Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New Database Pas" _
        , _
        "sword="""";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on Compact=False;Je" _
        , _
        "t OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False;Jet OLEDB:Support Complex Data=False" _
        ), Destination:=Range("$A$1")).QueryTable
        .CommandType = xlCmdTable
        .CommandText = Array("DDD")
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .SourceDataFile = FileName
        .ListObject.DisplayName = "テーブル_" & Replace(Mid(FileName, InStrRev(FileName, "\") + 1), ".mdb", "") & "_2" 'bbb.mdb "テーブル_ここがアクセスデータの名前_2"
        .Refresh BackgroundQuery:=False
    End With
End Sub

（ウッシ）

 ウッシありがとうございます。

 私の説明不足でした。
 Macro1とMacro2を合体したようなものは無理でしょうか？
 といいますのが、
 DDD:テーブルをAAA.xlsのSheet2
 EEE:テーブルをAAA.xlsのSheet3
 FFF:テーブルをAAA.xlsのSheet4
 FFF:テーブルをAAA.xlsのSheet5
 の様に、複数の貼り付けをしたいので、アクセスデータの設定(選択？)
 は一度にしたいのです。可能でしたら教えてください。
 (TM)

 この先、Excel/VBAから　mdbファイルに接続して複雑なことがしたいなら、
 DAO（mdb専用）、ADO（いろんなDBファイル用）等、mdbファイルを操作できるオブジェクトを使うことも検討してみてください。

 これらのコード例は、いくつもあると思いますから・・・・。

 ichinose

こんにちは

自分でやるなら最初から、DAOかADO でやりますけど、一応続きとして、

 Sub test_3()
    Dim FileName  As Variant
    Dim Sh1       As Worksheet
    Dim i         As Long
    Dim t         As Variant

    ChDir ThisWorkbook.Path
    FileName = Application.GetOpenFilename("MDB ファイル (*.mdb),*.mdb")
    If VarType(FileName) = vbBoolean Then Exit Sub

    t = Array("CCC", "DDD", "EEE", "FFF", "GGG") '("ここがテーブルの名前")

    For i = 0 To UBound(t)
        On Error Resume Next
        Set Sh1 = Worksheets("Sheet" & i + 1)
        If Err.Number <> 0 Then
            Set Sh1 = Worksheets.Add(After:=Worksheets(Worksheets.Count))
            Err.Clear
        End If
        Sh1.Cells.Delete
        Sh1.Range("A1").ListObject.ListColumns(1).Delete
        On Error GoTo 0
        Application.Goto Sh1.Range("A1")
        Call test_3_1(CStr(FileName), Sh1, t(i), i + 1)
    Next
End Sub
Sub test_3_1(f As String, s As Worksheet, tb As Variant, j As Long)
    With s.ListObjects.Add(SourceType:=0, Source:=Array( _
        "OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;Password="""";User ID=Admin;Data Source=" & f & ";Mode=Share Deny Write;Extended Pr" _
        , _
        "operties="""";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Jet OLEDB:Engine Type=5;Jet O" _
        , _
        "LEDB:Database Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New Database Pas" _
        , _
        "sword="""";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on Compact=False;Je" _
        , _
        "t OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False;Jet OLEDB:Support Complex Data=False" _
        ), Destination:=Range("$A$1")).QueryTable
        .CommandType = xlCmdTable
        .CommandText = Array(tb)
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .SourceDataFile = f
        .ListObject.DisplayName = "テーブル_" & Replace(Mid(f, InStrRev(f, "\") + 1), ".mdb", "") & "_" & j
        .Refresh BackgroundQuery:=False
    End With
 End Sub

（ウッシ）

 ウッシさん毎度ありがとうございます。
 実行できました。
 もしよろしければDAOかADOというのを使ったコードを教えていただけたらうれしいのですが、、、
 (TM)

こんにちは

 DAO 版です。簡略に書くとこんな感じです。
 以下、標準モジュールに、

 'VBE画面　メニュー、ツール、参照設定から
 '参照設定要　「Microsoft DAO 3.x Object Library」

 Dim ws As DAO.Workspace
Dim db As DAO.Database
Dim rs As DAO.Recordset

 Sub DAO_1()
    Dim FileName  As Variant
    Dim Sh1       As Worksheet
    Dim i         As Long
    Dim t         As Variant

    ChDir ThisWorkbook.Path
    FileName = Application.GetOpenFilename("MDB ファイル (*.mdb),*.mdb")
    If VarType(FileName) = vbBoolean Then Exit Sub

    t = Array("CCC", "DDD", "EEE", "FFF", "GGG") '("ここがテーブルの名前")

    Set ws = DBEngine.Workspaces(0)
    Set db = ws.OpenDatabase(FileName)

    For i = 0 To UBound(t)
        On Error Resume Next
        Set Sh1 = Worksheets("Sheet" & i + 1)
        If Err.Number <> 0 Then
            Set Sh1 = Worksheets.Add(After:=Worksheets(Worksheets.Count))
            Err.Clear
        End If
        On Error GoTo 0
        Sh1.Cells.Delete
        Call DAO_1_1(Sh1, t(i))
    Next

    rs.Close
    Set rs = Nothing
    db.Close
    Set db = Nothing
    ws.Close
    Set ws = Nothing
End Sub

 Sub DAO_1_1(s As Worksheet, tb As Variant)
    Dim i As Long
    Set rs = db.OpenRecordset(tb, dbOpenDynaset)
    For i = 1 To rs.Fields.Count
        s.Cells(1, i).Value = rs.Fields(i - 1).Name
    Next
    s.Range("A2").CopyFromRecordset rs
End Sub

（ウッシ）

コメント返信：

[ 一覧(最新更新順) ]

[[20100811153656]] 『アクセスデータ』（TM） ページの最後に飛ぶ

[[20100811153656]]　『アクセスデータ』（TM）　ページの最後に飛ぶ