Access (VBA)

Access VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Pro : Access 2016)
複数レコードの値をエクセルに書き込み
投稿日時: 20/01/28 22:04:51
投稿者: ひろと

ACCESSのテーブル(クエリでも)の複数値をエクセルに書き込みたいのですが、可能でしょうか。
 
やりたい事は、
テーブルAのフィールド1の値をエクセルのシート1のA1に、フィールド2の値をシート1のA2に入力。
レコード数は10あり、エクセルのシートを10にする事はできます。
 
エクセルをACCESSからコントロールする事もできるのですが、必要レコードのフィールド値をシート1〜10のA1とA2に入れる方法がわかりません。

回答
投稿日時: 20/01/29 10:21:14
投稿者: よろずや

Option Compare Database
Option Explicit

Sub Sample()
    Dim rs As ADODB.Recordset
    Set rs = New ADODB.Recordset
    rs.Open "テーブル1", CurrentProject.Connection, adOpenKeyset, adLockReadOnly
    If Not rs.EOF Then
        Dim xls As Object ' Excel.Application
        Set xls = CreateObject("Excel.Application")
        Dim Wb As Object ' Excel.Workbook
        Set Wb = xls.Workbooks.Add
        Do Until rs.EOF
            Dim i As Long
            i = i + 1
            With Wb.Worksheets
                If .Count < i Then .Add after:=Wb.Worksheets(.Count)
            End With
            With Wb.Worksheets(i)
                .Range("A1").Value = rs.Fields(0).Value
                .Range("A2").Value = rs.Fields(1).Value
            End With
            rs.MoveNext
        Loop
        xls.Visible = True
        xls.UserControl = True
        Set xls = Nothing
    End If
    rs.Close
End Sub

 
ってな感じ。

回答
投稿日時: 20/01/29 10:23:05
投稿者: sk

引用:
テーブルAのフィールド1の値をエクセルのシート1のA1に、
フィールド2の値をシート1のA2に入力。
レコード数は10あり、エクセルのシートを10にする事はできます。

(標準モジュール)
-------------------------------------------------------------------
Sub OutputRecordsToExcel()
On Error GoTo Err_OutputRecordsToExcel
 
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
 
    Dim xlsApp As Object 'Excel.Application
    Dim xlsWorkbook As Object 'Excel.Workbook
    Dim xlsWorksheet As Object 'Excel.Worksheet
 
    Dim strSQL As String
    Dim lngSheetIndex As Long
 
    Set db = CurrentDb()
     
    strSQL = "SELECT * FROM [テーブルA]"
     
    Set rs = db.OpenRecordset(strSQL, dbOpenSnapshot)
     
    If rs.EOF Then
        Set rs = Nothing
        Set db = Nothing
        MsgBox "出力対象となるレコードはありません。", vbInformation, "該当レコードなし"
        Exit Sub
    End If
 
    Set xlsApp = CreateObject("Excel.Application")
    xlsApp.Visible = True
    xlsApp.ScreenUpdating = False
     
    Set xlsWorkbook = xlsApp.Workbooks.Add
     
    lngSheetIndex = 0
     
    Do Until rs.EOF
        lngSheetIndex = lngSheetIndex + 1
        With xlsWorkbook.Worksheets
            If .Count < lngSheetIndex Then
                Set xlsWorksheet = .Add(After:=.Item(.Count))
            Else
                Set xlsWorksheet = .Item(lngSheetIndex)
            End If
        End With
         
        With xlsWorksheet
            .Cells(1, 1) = rs![フィールド1]
            .Cells(2, 1) = rs![フィールド2]
        End With
         
        Set xlsWorksheet = Nothing
         
        rs.MoveNext
    Loop
     
    With xlsWorkbook.Worksheets
        Do While .Count > rs.RecordCount
            .Item(.Count).Delete
        Loop
    End With
     
    xlsWorkbook.Worksheets(1).Activate
     
Exit_OutputRecordsToExcel:
On Error Resume Next
     
    Set xlsWorksheet = Nothing
    Set xlsWorkbook = Nothing
    xlsApp.ScreenUpdating = True
    Set xlsApp = Nothing
     
    Set rs = Nothing
    Set db = Nothing
     
    Exit Sub
 
Err_OutputRecordsToExcel:
     
    Dim strErrMsg As String
 
    strErrMsg = Err.Number & ": " & Err.Description
    Debug.Print strErrMsg
     
    MsgBox strErrMsg, vbCritical, "実行時エラー(OutputRecordsToExcel)"
 
    Resume Exit_OutputRecordsToExcel
End Sub
-------------------------------------------------------------------
 
以上のようなコードを実行なさりたい、ということでしょうか。
 
引用:
必要レコードのフィールド値をシート1〜10のA1とA2に入れる

任意の条件に該当するレコードの絞り込みや、
任意の順番によるレコードの並べ替えを行ないたい場合は、
SQL 文の中で WHERE 句や ORDER BY 句を指定するようにして下さい。
 
引用:
ACCESSのテーブル(クエリでも)の複数値をエクセルに書き込みたい

また、パラメータクエリを使用してレコードセットを取得したい場合は
DAO.QueryDef オブジェクトを使用したコードに書き換えることになるでしょう。

投稿日時: 20/02/09 18:05:04
投稿者: ひろと

ご教示いただきありがとうございます。
 
目的の動作ができました。