Access エクセル出力（クロス集計）

クロス集計サンプル

Private Sub 出力_Click()

'ADOセット定義
    Dim rs As New ADODB.Recordset

    'エクセルエクスポート定義
    Dim objApp As Object
    Dim objWkb As Object
    Dim objWsh As Object

    '書出しCellsの定義
    Dim SCol As Integer
    Dim SRow As Integer
    
    'エクセルのRange対応配列
    Dim Ran As Variant

    '日付Range   0    1    2    3    4    5    6    7    8    9    10   11   12   13   14   15   16   17   18   19   20   21   22   23   24    25    26    27    28    29    30    31
    Ran = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "AA", "AB", "AC", "AD", "AE", "AF", "AG", "AH")

   
    '書出しCell位置
    SRow = 6  '行
    SCol = 3  '行
   
     '出力先のエクセルを利用できるように設定
     Set objApp = CreateObject("Excel.Application")
    
     'エクセルのパスを指定
     Set objWkb = objApp.Workbooks.Open("C:\Users\root\Desktop\Access\エクセル出力10_クロス集計ver02\test.xlsx")
   
    'Sheet名を指定
     Set objWsh = objWkb.Worksheets("Sheet1")
   
    ''''''''''''''''''''''''''''''''''''''''''''''''''
    '書出し
    ''''''''''''''''''''''''''''''''''''''''''''''''''
   
    '書出しCell位置
    SRow = 1
    SCol = 3
   
   
   
    ''''''''''''''''''''''''''''''''''''''''''''''''''
    '日付の出力
    ''''''''''''''''''''''''''''''''''''''''''''''''''
    MySQL = "SELECT 日付 FROM T_勤怠 GROUP BY 日付 ORDER BY 日付"
   
    rs.Open MySQL, CurrentProject.Connection

    '取得したデータ起点のCellsから個別に出力
    Do Until rs.EOF
        objWsh.Cells(SRow, SCol + 1).Value = rs!日付.Value
        SCol = SCol + 1
        rs.MoveNext
    Loop
   
    rs.Close
    Set rs = Nothing
   
   
   
   
    '書出しCell位置
    SRow = 2
    SCol = 1
   
    ''''''''''''''''''''''''''''''''''''''''''''''''''
    'データの出力
    ''''''''''''''''''''''''''''''''''''''''''''''''''
    MySQL = "SELECT ID,開始時間,終了時間,休憩時間,勤務時間 FROM T_勤怠 ORDER BY ID,日付"
  
    rs.Open MySQL, CurrentProject.Connection

    'IDの確保変数
    Dim TID As Long
    TID = rs!ID.Value

    '見出し【開始・休憩・終了・実働時間】の出力
   ' objWsh.Cells(2, 2).Value = "開始"

    '取得したデータ起点のCellsから個別に出力
    Do Until rs.EOF
    
        If TID = rs!ID.Value Then
            
            'データの出力
            objWsh.Cells(SRow + 0, 1).Value = rs!ID.Value
            objWsh.Cells(SRow + 0, SCol + 3).Value = rs!開始時間.Value
            

            SCol = SCol + 1
            TID = rs!ID.Value

        'IDが変わったら
        Else

                '行数の追加
                SRow = SRow + 1
         
        
                '列の初期化
                SCol = 1
                'データの出力
                objWsh.Cells(SRow + 0, 1).Value = rs!ID.Value
                objWsh.Cells(SRow + 0, SCol + 3).Value = rs!開始時間.Value

                SCol = SCol + 1
                
                'IDの設定
                TID = rs!ID.Value
        End If
        rs.MoveNext
   Loop
   

    rs.Close
    Set rs = Nothing

  '保存
  objWkb.Save
  objWkb.Close
  objApp.Quit

  'Excel Close処理
  Set objApp = Nothing
  Set objWkb = Nothing
  Set objWsh = Nothing
 
  MsgBox "完了。"

End Sub