饂飩コーディング

iOSアプリやら、Unityやら、Cocos2dやらごにょごにょ書いております

フォームのレコードソースをExcelで出力する。

サイトが引っ越しました。→https://scombu.com

約1秒後に自動的にリダイレクトします。切り替わらない場合はリンクをクリックしてください。

「Accessのフォームから、データをかんたんにExcelに出力する方法」~VBAで関数にしちゃいましょ♪~ |


AccessからVBAでEXCELへ帳票出力する|アズビーパートナーズ




参考にさせていただきました。

'Excelにデータを出力
Function ExcelData(frm As Form)
    On Error GoTo Err_cmdExcel_Click

    'DAOで抽出結果のクローンを作成
    Dim xls As Object 'Excel.Applicationを代入するオブジェクト変数
    Dim wkb As Object 'Excel.Wookbookを代入するオブジェクト変数
    Dim rst As DAO.Recordset '現在のレコードセットを入れる変数
    Dim idx As Long  'フィールド数変数

    Set rst = Nothing 'データリストの初期化
    Set rst = frm.RecordsetClone  'フォームのレコードセットのクローンを代入

    'レコードが存在しない場合、処理を中止
    If rst.BOF = True And rst.EOF = True Then
        MsgBox "出力出来るデータがありません。", vbOKOnly + vbExclamation, "出力不可"
        'レコードセットを閉じる
        rst.Close: Set rst = Nothing
        Exit Function
    End If

    'レコードが存在する場合、Excelに出力
    'レコードセットの最初のデータにカーソルを移動
    rst.MoveFirst

    'Excelファイルを内部的に作成
    Set xls = CreateObject("Excel.Application")
    '作成されたExcelファイルにワークブックを追加
    Set wkb = xls.Workbooks.Add()
    'Worksheets(1).Name = "売上データ"
    wkb.Worksheets(1).Name = "マスタ"

    '追加されたワークブックに、レコードセットのデータをコピー
    With wkb.Worksheets(1)
        For idx = 1 To rst.Fields.Count
            .Cells(1, idx).Value = rst.Fields(idx - 1).Name
        Next
        .Range("A2").CopyFromRecordset Data:=rst
        .columns(rst.Fields.Count).Delete '最終列の削除をする場合はこの行で削除する。
    End With
    
    
    'ファイル名作成
    Dim strFileName     As String
    strFileName = "sample3" & "_" & Format(Date, "yyyymmdd") & ".xlsx"
    '完了したら保存
    xls.ActiveWorkBook.SaveAs FileName:=strFileName
       

    'レコードセットを閉じる
    rst.Close: Set rst = Nothing
    'Excelデータを表示
    
'    xls.Visible = True
'    xls.UserControl = True
    
    xls.Visible = False
    xls.UserControl = False
    
    
    'メモリに展開されたExcel用オブジェクト変数を開放
    Set wkb = Nothing
    Set xls = Nothing

Exit_cmdExcel_Click:
    Exit Function

Err_cmdExcel_Click:
    'エラーの場合、エラーNOと内容を表示
'    MsgBox Err.Number & Err.Description
    MsgBox "エラーのため、Excelへ出力できません。" & vbCrLf & "一旦フォームを閉じ、再度トライしてください。", _
    vbOKOnly + vbCritical, "Excel出力不可!"
    Resume Exit_cmdExcel_Click
End Function


呼び出し側

Private Sub cmdExcel_Click()
    'Meは、このフォームという意味
    Call ExcelData(Me)

    '(forms!Form商品一覧というように、ここにフォーム名を指定してもOK!)
    'Call ExcelData(Forms!商品一覧)
End Sub