ACCESS から EXCEL へ出力！ VBA のひな形、作ってみました ～明日見むら～ やってみよう、意外と簡単！ アクセス講座
--- 2018-07-07 ---
只今、ブログをお引越し中でございます
も少し、落ち着いたら、
もっとキレイなのをアップします
ボランティアAPP がイケそうだったら、まるっとソレでイケると思います
今暫くお待ち下さい
---
ACCESS から EXCEL へ出力！ VBA のひな形、作ってみました
やってみよう、意外と簡単なのネ！
でも、奥は深いですゾヨ(^^;
とりあえず、以下のひな形をコピペします
後ほど、説明カキコするかも！
(^^)
------------
Option Compare Database
Option Explicit
'（修正履歴）-------------------------------------
'2014-01-01：バグ修正 DoEvents 追加
'-------------------------------------------------
Private DB As Database
Private REC As Recordset
Private SQL As String
'
Public Function FUNC_R3030_OP()
Call R3030_MAIN
End Function
Private Sub R3030_MAIN()
On Error Resume Next
DoCmd.Hourglass True '砂時計 ON Screen.MousePointer = 11
DoCmd.SetWarnings False
Set DB = CurrentDb
Call R3030_RPT_OP
DB.Close
Set REC = Nothing
Set DB = Nothing
SQL = ""
DoCmd.SetWarnings True
DoCmd.Hourglass False
Interaction.Beep
End Sub
Private Sub R3030_RPT_OP()
Dim OBJ As Object
Dim SHEET As Object
Dim PATH_COM As String
Dim PATH_RPT As String
Dim BOOK_NM1 As String
Dim BOOK_NM2 As String
Dim X_COL As Integer
Dim Y_ROW As Integer
Dim w_NM As String
Dim i As Integer
'---（基本情報）---
On Error GoTo err_ex_2 'ERROR EXCEL
'EXCEL 保存元／先 PATH を取得
PATH_COM = "F:\Redhp300G\APP\COM"
PATH_RPT = "F:\Redhp300G\APP\RPT"
With [Forms]![F3030_Ｇ３印刷]
BOOK_NM1 = "\R3030_Ｒ３帳票"
BOOK_NM2 = "\R3030_Ｒ３帳票"
BOOK_NM1 = PATH_COM & BOOK_NM1 & ".xls" '元：入力・ひな形
BOOK_NM2 = PATH_RPT & BOOK_NM2 & ".xls" '先：出力・Excel加工後
End With
'Excel の起動
Set OBJ = CreateObject("Excel.Application")
OBJ.WorkBooks.Open BOOK_NM1
OBJ.DisplayAlerts = False '確認メッセージなしに保存する-->
OBJ.WorkBooks(1).SaveAs BOOK_NM2
OBJ.DisplayAlerts = True '-->戻す
Set SHEET = OBJ.WorkSheets(1)
OBJ.Visible = True
OBJ.ScreenUpdating = False '更新：stop
On Error GoTo err_ex_1 'ERROR DB
'******************
'* Ｐ１シート * Sheets(1)
'******************
With [Forms]![F3030_Ｇ３印刷]
'---（タイトル）---
w_NM = "作成日：" & Format(Now, "gggee/mm/dd（aaa） hh:nn")
SHEET.Cells(1, 8) = w_NM
End With
'---（明細）---
'ソート順、等クエリ側で設定 ※項目＝レコードとエクセルの順番を合わせている
SQL = "SELECT * FROM Q3030_P1DAT;"
Set REC = DB.OpenRecordset(SQL, dbOpenSnapshot) '読み取り専用
If Not REC.EOF Then '条件により抽出されない場合がある！
REC.MoveLast 'カーソル位置を最後へ
End If
'---（タイトル）---
w_NM = Format(REC.RecordCount, "#,##0") & " 件"
SHEET.Cells(1, 5) = w_NM
'---（明細）---
'抽出件数を取得し、空の行をあらかじめ作成し、その後データをセットする
i = REC.RecordCount
i = i - 1 '１行分は作成済の為
Y_ROW = 3 '基準：行
X_COL = 1 ' ：列
' （範囲指定でコピーする方法）
If i < 1 Then GoTo sheet_11
'xlPasteValues = -4163, xlNone = -4142, xlPasteAll = -4104
SHEET.Rows(Y_ROW).Copy
SHEET.Rows(Y_ROW + 1 & ":" & i + Y_ROW).PasteSpecial Paste:=-4104, Operation:=-4142, SkipBlanks:=False, Transpose:=False
OBJ.CutCopyMode = False '切り取りモードを解除する
OBJ.WorkSheets(1).Select '複数シートの時は一旦シートを選択しないとセルを選択できない！
SHEET.Cells(1, 1).Select '※上記「貼り付け」時は範囲選択も解除する事！（処理が異常に遅くなる）
sheet_11:
If Not REC.EOF Then '条件により抽出されない場合がある！
REC.MoveFirst 'カーソル位置を最初へ
End If
Do Until REC.EOF
For i = 0 To REC.Fields.Count - 1
SHEET.Cells(Y_ROW, X_COL + i) = REC(i)
Next
Y_ROW = Y_ROW + 1
REC.MoveNext
Loop
REC.Close
'******************
'* Ｐ２シート * Sheets(2)
'******************
''' Set SHEET = OBJ.WorkSheets(2)
err_ex_1: '『Normal End 共用』
OBJ.ScreenUpdating = True '更新：start
'OBJ.Visible = True
OBJ.DisplayAlerts = False '確認メッセージなしに保存する-->
OBJ.WorkBooks(1).SaveAs BOOK_NM2
OBJ.DisplayAlerts = True '-->戻す
GoTo sub_ex
err_ex_2:
On Error Resume Next
OBJ.Application.Quit
w_NM = "『Ｒ３帳票』作成出来ませんでした。" _
& vbCrLf & "同一名のＥｘｃｅｌが起動中の為だと思われます。" _
& vbCrLf & "一旦、終了させてから再度作成して下さい！"
MsgBox w_NM, vbOKOnly + vbCritical, "(R3030) Ｒ３帳票"
sub_ex:
Set SHEET = Nothing
Set OBJ = Nothing
w_NM = ""
PATH_COM = "": PATH_RPT = ""
BOOK_NM1 = "": BOOK_NM2 = ""
End Sub
----------
等角フォントでないとキレイになりませんネ！
メモ帳にでも、コピペしたら見やすくなります
アクセス講座 始めるかも、、、
---
明日見むら
村長さんでした
(^^)/
asumi-mura
---
