2017-10-26 79 views
0

Accessデータベース(現在開いているデータベース)から指定された1つのクエリテーブルのすべてのデータをMSにインポートするAccess VBAコードのヘルプが必要ですExcel(ユーザーが選択できるファイル)。Access VBAを使用したAccessからAccessへのデータのインポート

私は現在、コードのこの部分を抱えているが、私は、エラー・メッセージと言っ取得しています:

オートメーションエラー:

「実行時エラー 『-2147023170(800706be)』をリモートプロシージャコールは失敗しました。

どのように接続を修正するか知っていますか?このステップで

Option Explicit 
Option Compare Database 

    Public Sub CopyRstToExcel_test() 
    'On Error GoTo CopyRstToExcel_Err 

     Dim sPath As String 
     Dim fd As FileDialog 
     Dim oExcel As Object 
     Dim oExcelWrkBk As Object 
     Dim oExcelWrSht As Object 

     Dim dbs 'Added 
     Dim qdfName As String 
     Dim fRecords As Boolean 

     Dim rst As dao.Recordset 

     Dim iCols As Integer 

     '------------------------------------------------------------------------------------------------------------------------------------------------------------------- 
     ' Select the file and identify the path leading to the file 
     '------------------------------------------------------------------------------------------------------------------------------------------------------------------- 

     'Define database you want to work with 
     Set dbs = CurrentDb 

     'Select the Excel file you want to work with 
     Set fd = Application.FileDialog(msoFileDialogFilePicker) 

     'Define the path 
     If fd.Show = -1 Then 
      sPath = fd.SelectedItems(1) 
     End If 

     MsgBox sPath 

     '------------------------------------------------------------------------------------------------------------------------------------------------------------------- 
     ' Defining names of variables 
     '------------------------------------------------------------------------------------------------------------------------------------------------------------------- 

     'Defining variables (queries/tables) 
     qdfName = "Query_1" 

     '------------------------------------------------------------------------------------------------ 
     'Copying the data from Access into the new Excel 
     '------------------------------------------------------------------------------------------------ 

     Set rst = CurrentDb.OpenRecordset(qdfName, dbOpenSnapshot) 

     fRecords = False 
     If rst.EOF = False Then 
      fRecords = True 

      Set oExcel = CreateObject("Excel.Application") 
      Set oExcelWrkBk = GetObject(sPath) 

      oExcel.Visible = True 
      oExcel.ScreenUpdating = False 

      Set oExcelWrSht = oExcelWrkBk.Sheets(1) 

      For iCols = 0 To rst.Fields.Count - 1 
       oExcelWrSht.Cells(9, iCols + 2).Value = rst.Fields(iCols).Name 
      Next 

      oExcelWrSht.Range(oExcelWrSht.Cells(9, 2), _ 
       oExcelWrSht.Cells(9, rst.Fields.Count)).Font.Bold = True 

      oExcelWrSht.Range("B10").CopyFromRecordset rst 

      oExcelWrSht.Range(oExcelWrSht.Cells(9, 2), _ 
       oExcelWrSht.Cells(rst.RecordCount + 9, rst.Fields.Count)).Columns.AutoFit 

      oExcelWrSht.Range("A1").Select 

     End If 


    '------------------------------------------------------------------------------------------------ 
    CopyRstToExcel_Done: 
     On Error Resume Next 
     If fRecords = True Then 
      oExcel.Visible = True 
      oExcel.ScreenUpdating = True 
     End If 
     Set oExcelWrSht = Nothing 
     Set oExcelWrkBk = Nothing 
     Set oExcel = Nothing 
     Set rst = Nothing 

    ''Error message: 
    'CopyRstToExcel_Err: 
    ' MsgBox Err & ": " & Error, vbExclamation 
    ' Resume CopyRstToExcel_Done 
    ' Resume 
    '------------------------------------------------------------------------------------------------ 

    End Sub 

、私は最初のシートにデータをコピーしたいのですが、後に、私はまた、シートの名前を指定したいと私はすでに私がコピーする準備テンプレートを持っていますデータは上書きされます。

ありがとうございました!

+2

指定してください(これはライン) –

答えて

0

はまた、私は

Set rst = dbs.OpenRecordset(qdfName, dbOpenSnapshot) 
によって

Set rst = CurrentDb.OpenRecordset(qdfName, dbOpenSnapshot) 

を交換することをお勧めしたい

Set oExcelWrkBk = oExcel.Workbooks.Open(sPath) 

によって

Set oExcelWrkBk = GetObject(sPath) 

を交換してください

オープン指定したワークシート:あなたはこのエラーを取得する場所

Set oExcelWrSht = oExcelWrkBk.Sheets("MyWorksheetName") 
+0

優れた、どうもありがとうございました!これらは私が必要としていた調整とまったく同じでした。 – LuckyLuke

関連する問題