AccessVBA：【出力】1行目にヘッダーのないExcelテンプレートへの出力方法
出力するフォーマットが指定されたものもは1行目にフィールド名があるとは限りません。そのような様々なフォーマットにも、変数を変更することで対応できるようなプログラムを以下に載せておきます。
◆テンプレートとしてのExcelへの出力
以下サンプルコードになります。
保存先やファイル名、シート名、テンプレートの行や列など、但し書き部分を変更して試してみてください。
|
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 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 |
Private Sub Excel出力_Click() Dim xSQL As String Dim strTemplate As String Dim SaveFilePath As String Dim SaveFolderPath As String Dim TemplatePath As String Dim FileName As String Dim OutSheetName As String Dim OutTName As String Dim TemplateRow As Long Dim TemplateCol As Long Dim LastCol As Long Dim LastRow As Long Dim xlapp As Object Dim myCn As New ADODB.Connection Dim myRs As New ADODB.Recordset Dim wb As Workbook 'テンプレートファイルの指定' TemplatePath = "C:\Users\chasou00\Documents\茶窓\wp_tech\11記事\VBA\各種フォーマット\フォーマット1.xlsx" '出力したExcelの保存フォルダ' SaveFolderPath = "C:\Users\chasou00\Documents\茶窓\wp_tech\11記事\VBA\出力フォルダ" '出力するファイル名' FileName = "出力ためし" OutSheetName = "Sheet2" '書式レコード起点。出力されたレコード全てに網掛けなどの書式を反映させたいため' TemplateRow = 3 'ここではレコードが入るのが3行目からなので、3行目をテンプレートとしておく' TemplateCol = 1 'フィールド名の入っている最初の列' '出力するAccessのテーブル名。クエリでもOK' OutTName = "サンプル1" '保存先フォルダとファイル名の作成' SaveFilePath = SaveFolderPath & "\" & FileName & ".xlsx"'" 'EXCELを起動' Set xlapp = CreateObject("Excel.Application") 'データをセットする過程が見えないよう一旦不可視' xlapp.Visible = False Set myCn = CurrentProject.Connection xSQL = "SELECT * FROM " & OutTName & "" myRs.Open xSQL, myCn, adOpenForwardOnly, adLockReadOnly With xlapp If Dir(TemplatePath) = "" Then MsgBox "テンプレートファイルを確認してください。", vbOKOnly + vbCritical, "エラー" .Visible = True .Quit Exit Sub End If Set wb = .Workbooks.Open(TemplatePath) End With '結果出力処理' With wb.Worksheets(OutSheetName) '取得したデータをテンプレートに書き込む' .Cells(TemplateRow, TemplateCol).CopyFromRecordset myRs '書き込まれたレコードの最終行を取得' LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'テンプレートの最終列を取得。' LastCol = .Cells(TemplateRow - 1, .Columns.Count).End(xlToLeft).Column '最初のレコード行の書式をコピペ' .Range(.Cells(TemplateRow, TemplateCol), .Cells(TemplateRow, LastCol)).Copy .Range(.Cells(TemplateRow + 1, TemplateCol), .Cells(LastRow, LastCol)).PasteSpecial (xlPasteFormats) .Cells(TemplateRow, TemplateCol).Select End With '完了したら保存' wb.SaveAs FileName:=SaveFilePath Set wb = Nothing: Close Set myRs = Nothing: Close Set myCn = Nothing: Close xlapp.Quit 'Excelを終了する' MsgBox "完了" End Sub |
