Excel への自力出力例（ベタ その２）
Excel への自力出力例（ベタ） で記述ミスしたので、サンプル修正も兼ねて他の方法での出力を紹介したいと思います。
テーブル構成等は、Excel への自力出力例（ベタ） を見てください。
起動メニューを７つ用意しました。
フォームの構成は同じで、ボタンをクリックした時の処理を変えてます。
（フォーム単独で流用したい時に便利なように）
「F1」は、SUM / SUMIF を使用した Excel への自力出力例（ベタ） のフォームそのまま。
「F2」は、SUBTOTAL 関数を使用したもの。
（SUMIF では、固定文字列 "小計" をキーに集計していたので、"小計"部分を変更したい時に使えるかな）
「F3」は、SUBTOTALメソッドを使用して、集計全てをExcelでしてもらうもの。
「F1」「F2」「F3」でのExcel出力結果になります。
他のフォームは、Excel に用意されているレコードセットをまとめてコピーする CopyFromRecordset を使用した例になります。
「F7」は、項目名を展開後、単純に CopyFromRecordset を実行。
（テーブル「T1」をメニューでExcelへエクスポートした時と同じ）
「F7」でのExcel出力結果になります。
「F1」〜「F3」と同じ項目並びにしたレコードセットを
「F4」は、CopyFromRecordset 実行後、SUBTOTALメソッドで集計。
「F5」は、「F4」を元に項目展開時に列に対して書式を設定し CopyFromRecordset ＆ SUBTOTALメソッドで集計。
「F6」は、「F5」のレコードセットを得る時に項目順を指定しなかった時の例になります。
「F4」「F5」「F6」でのExcel出力結果になります。
-
メニューフォーム「F_MENU」の作成）
非連結のフォームとして作ります。
オプショングループ「op1」をトグルボタン（値：１〜７）で作成します。
既定値は設定しません。
不要な「レコードセレクタ」「移動ボタン」は「いいえ」とし、ポップアップを「はい」とします。
それなりに見栄えを整えた後、オプショングループの「クリック時」にフォームの起動処理等を記述していきます。
VBAで記述した内容は以下
Private Sub op1_Click()
Dim sName As String
Select Case Me.op1
Case 1: sName = "F1"
Case 2: sName = "F2"
Case 3: sName = "F3"
Case 4: sName = "F4"
Case 5: sName = "F5"
Case 6: sName = "F6"
Case 7: sName = "F7"
End Select
DoCmd.OpenForm sName
DoCmd.Close acForm, Me.Name, acSaveNo
End Sub
フォーム「F1」の作成）
Excel への自力出力例（ベタ） の記述ミスを修正し、フォームの「閉じる時」にメニューを起動する処理を追加します。
追加した内容は以下
Private Sub Form_Close()
DoCmd.OpenForm "F_MENU"
End Sub
フォーム「F2」の作成）
フォーム「F1」をコピーし、SUM / SUMIF 作成部分を、SUBTOTAL を使用するように変更します。
また、小計部分に、小計をした名称を付加するように処理を追加します。
なお、フォーム「F1」で SUM を記述したセルには書式を設定しませんでしたが、SUBTOTAL を設定するセルの書式はチャンと設定しておきます。
（何故なんでしょう、違いがわかりません。Excelは難しぃ）
VBAでの記述内容は以下
Const SYOUKEI = "小計"
Dim sTitle As String
Private Function exColumnString(iNum As Long) As String
Dim sS As String
Dim i As Long
Dim iBase As Integer
sS = ""
i = iNum
iBase = Asc("A")
While (i > 0)
If (i > 26) Then
sS = Chr(iBase + ((i - 1) Mod 26)) & sS
i = Int((i - 1) / 26)
Else
sS = Chr(iBase + i - 1) & sS
i = -1
End If
Wend
exColumnString = sS
End Function
Private Sub SetMerge(oApp As Object, iRowS As Long, iRowE As Long, iColS As Long, iColE As Long)
Dim sS As String
Dim sE As String
sS = exColumnString(iColS)
sE = exColumnString(iColE)
oApp.Range(sS & iRowS & ":" & sE & iRowE).Merge
End Sub
Private Sub MergeSyoukei(oApp As Object, iRow As Long, iColS As Long, iColE As Long)
oApp.Cells(iRow, iColS) = SYOUKEI & " (" & Mid(sTitle, 2) & ")"
Call SetMerge(oApp, iRow, iRow, iColS, iColE)
End Sub
Private Sub SetSubtotal(oApp As Object, iRow As Long, iRowS As Long, iCol As Long)
Dim sTmp As String
sTmp = "=SUBTOTAL(9,R[-" & iRow - iRowS & "]C:R[-1]C)"
With oApp
.Cells(iRow, iCol).NumberFormatLocal = "#,##0_ "
.Cells(iRow, iCol).FormulaR1C1 = sTmp
End With
End Sub
Private Sub btn1_Click()
Dim rs As New ADODB.Recordset
Dim iGsave As Long
Dim oApp As Object
Dim iRowStart As Long
Dim iRow As Long
Const iRowBase = 3
Const iColBase = 2
rs.Source = "SELECT * FROM T1 ORDER BY グループ, コード ;"
rs.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
If (Not rs.EOF) Then
Set oApp = CreateObject("Excel.Application")
With oApp
.Workbooks.Add
iRow = iRowBase
.Cells(iRow, iColBase + 0) = "グループ"
.Cells(iRow, iColBase + 1) = "コード"
.Cells(iRow, iColBase + 2) = "名称"
.Cells(iRow, iColBase + 3) = "仕入額"
.Cells(iRow, iColBase + 4) = "前年比"
iGsave = -999999
While (Not rs.EOF)
iRow = iRow + 1
If (iGsave <> rs("グループ")) Then
If (iRow <> iRowBase + 1) Then
Call SetMerge(oApp, iRowStart, iRow - 1, iColBase + 0, iColBase + 0)
Call MergeSyoukei(oApp, iRow, iColBase + 0, iColBase + 2)
Call SetSubtotal(oApp, iRow, iRowStart, iColBase + 3)
iRow = iRow + 1
End If
iRowStart = iRow
iGsave = rs("グループ")
.Cells(iRow, iColBase + 0) = iGsave
sTitle = ""
End If
.Cells(iRow, iColBase + 1).NumberFormatLocal = "@"
.Cells(iRow, iColBase + 1) = rs("コード")
.Cells(iRow, iColBase + 2) = rs("名称")
sTitle = sTitle & "," & rs("名称")
.Cells(iRow, iColBase + 3).NumberFormatLocal = "#,##0_ "
.Cells(iRow, iColBase + 3) = rs("仕入額")
.Cells(iRow, iColBase + 4).NumberFormatLocal = "0%"
.Cells(iRow, iColBase + 4) = rs("前年比")
rs.MoveNext
Wend
iRow = iRow + 1
Call SetMerge(oApp, iRowStart, iRow - 1, iColBase + 0, iColBase + 0)
Call MergeSyoukei(oApp, iRow, iColBase + 0, iColBase + 2)
Call SetSubtotal(oApp, iRow, iRowStart, iColBase + 3)
iRow = iRow + 1
.Cells(iRow, iColBase + 0) = "合計"
Call SetMerge(oApp, iRow, iRow, iColBase + 0, iColBase + 2)
Call SetSubtotal(oApp, iRow, iRowBase + 1, iColBase + 3)
.Columns.EntireColumn.AutoFit
.Cells(1, 1).select
.Visible = True
.UserControl = True
End With
Set oApp = Nothing
End If
rs.Close
End Sub
Private Sub Form_Close()
DoCmd.OpenForm "F_MENU"
End Sub
フォーム「F3」の作成）
１行づつ処理することは変更しないので、「F1」「F2」どちらでも良いのでコピー元にしたコピーをします。
Excelの SUBTOTAL メソッドを使用しますが、「F1」「F2」の様にグループ部分をセル結合しているとまともに動いてくれません。
そこで、セル結合処理部分は丸々削除。
SUBTOTAL メソッドに指定する集計列は、項目順を意識した代入を行っているのでわかりきっています。
この部分、今回記述したのは以下となります。
.Range(sTmp).subtotal 1, -4157, 4
の 1 と 4 の部分になります。
範囲指定する１列目に「グループ」があり、４列目「仕入額」が集計対象になります。
途中の -4157 は、Excel 記述で xlSum にあたるもので、VBEの参照設定で Excel を参照していれば xlSum 記述でOKです。
今回 Excel を参照設定していないので、-4157 を直接記述します。
追記：3/13
.Range(sTmp).subtotal 1, -4157, 4
の正式な指定は
.Range(sTmp).subtotal 1, -4157, Array(4)
の様ですが、動いたのでそのまま使っています。
（内部で、配列なのか判別されているのだと思います。動かなければ良いのに･･･）
VBAでの記述内容は以下
Private Function exColumnString(iNum As Long) As String
Dim sS As String
Dim i As Long
Dim iBase As Integer
sS = ""
i = iNum
iBase = Asc("A")
While (i > 0)
If (i > 26) Then
sS = Chr(iBase + ((i - 1) Mod 26)) & sS
i = Int((i - 1) / 26)
Else
sS = Chr(iBase + i - 1) & sS
i = -1
End If
Wend
exColumnString = sS
End Function
Private Sub btn1_Click()
Dim rs As New ADODB.Recordset
Dim oApp As Object
Dim iRowStart As Long
Dim iRow As Long
Dim sColS As String
Dim sColE As String
Dim sTmp As String
Const iRowBase = 3
Const iColBase = 2
rs.Source = "SELECT * FROM T1 ORDER BY グループ, コード ;"
rs.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
If (Not rs.EOF) Then
Set oApp = CreateObject("Excel.Application")
With oApp
.Workbooks.Add
iRow = iRowBase
.Cells(iRow, iColBase + 0) = "グループ"
.Cells(iRow, iColBase + 1) = "コード"
.Cells(iRow, iColBase + 2) = "名称"
.Cells(iRow, iColBase + 3) = "仕入額"
.Cells(iRow, iColBase + 4) = "前年比"
While (Not rs.EOF)
iRow = iRow + 1
.Cells(iRow, iColBase + 0) = rs("グループ")
.Cells(iRow, iColBase + 1).NumberFormatLocal = "@"
.Cells(iRow, iColBase + 1) = rs("コード")
.Cells(iRow, iColBase + 2) = rs("名称")
.Cells(iRow, iColBase + 3).NumberFormatLocal = "#,##0_ "
.Cells(iRow, iColBase + 3) = rs("仕入額")
.Cells(iRow, iColBase + 4).NumberFormatLocal = "0%"
.Cells(iRow, iColBase + 4) = rs("前年比")
rs.MoveNext
Wend
sColS = exColumnString(iColBase + 0)
sColE = exColumnString(iColBase + 4)
sTmp = sColS & iRowBase & ":" & sColE & iRow
.Range(sTmp).subtotal 1, -4157, 4
.Columns.EntireColumn.AutoFit
.Cells(1, 1).select
.Visible = True
.UserControl = True
End With
Set oApp = Nothing
End If
rs.Close
End Sub
Private Sub Form_Close()
DoCmd.OpenForm "F_MENU"
End Sub
Excel の SUBTOTALメソッドを使用するのなら、１行１行自力で展開せずに、CopyFromRecordset を使った方が記述が少なくなって、しかも速く処理できるのでは？と思ってしまいます。
では、CopyFromRecordset を使って見よう･･･ということに。
フォーム「F7」の作成）
CopyFromRecordset を使用した単純な例として、フォーム「F7」を用意しました。
この実行結果は、単純にテーブル「T1」をメニュー等でExcelへエクスポートしたものと同じになります。
質問でよく、エクスポートした後で書式を変えたい、とか
エクスポートした後で、あるセルに情報を追加したい、とか
ありますが、
エクスポートした後で、Excelを起動して、開いて･･･という処理は記述すれば記述できないことはありませんが、
開いた時にエクスポートが終了している保証はないと思います。
こういう時には、自力で処理を記述した方が確かなような気がします。
VBAでの記述内容は以下
Private Sub btn1_Click()
Dim rs As New ADODB.Recordset
Dim oApp As Object
Dim iCol As Long
rs.Source = "SELECT * FROM T1 ORDER BY グループ,コード ;"
rs.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
If (Not rs.EOF) Then
Set oApp = CreateObject("Excel.Application")
With oApp
.Workbooks.Add
For iCol = 0 To rs.Fields.Count - 1
.Cells(1, iCol + 1) = rs(iCol).Name
Next
.Range("A2").CopyFromRecordset rs
.Visible = True
.UserControl = True
End With
Set oApp = Nothing
End If
rs.Close
End Sub
Private Sub Form_Close()
DoCmd.OpenForm "F_MENU"
End Sub
フォーム「F4」の作成）
フォーム「F3」をコピーします。
レコードセットを得る時に * にしているので、項目順がわかりません。
（CopyFromRecordset を使うと得た項目順で作成されるので）
SELECT で項目順を指定するようにします。
また、１行１行処理していくわけではないので、レコード数が欲しくなります。
そこで、adOpenForwardOnly 部分を、adOpenStatic に変更しておきます。
（出来上がった表の最終行とかはExcelの○○を使えば得られるようですが･･･、わかってません）
レコードセットで得られる項目順は出来上がったわけですが、
.Range(sTmp).subtotal
で指定する列は固定ではなく、処理で求めておくようにします。
VBAでの記述内容は以下
Private Function exColumnString(iNum As Long) As String
Dim sS As String
Dim i As Long
Dim iBase As Integer
sS = ""
i = iNum
iBase = Asc("A")
While (i > 0)
If (i > 26) Then
sS = Chr(iBase + ((i - 1) Mod 26)) & sS
i = Int((i - 1) / 26)
Else
sS = Chr(iBase + i - 1) & sS
i = -1
End If
Wend
exColumnString = sS
End Function
Private Sub btn1_Click()
Dim rs As New ADODB.Recordset
Dim oApp As Object
Dim iGroupColNumber As Long
Dim iSubtotalColNumber As Long
Dim iCol As Long
Dim sColS As String
Dim sColE As String
Dim sTmp As String
Const iRowBase = 3
Const iColBase = 2
rs.Source = "SELECT グループ,コード,名称,仕入額,前年比 FROM T1 ORDER BY グループ,コード ;"
rs.Open , CurrentProject.Connection, adOpenStatic, adLockReadOnly
If (rs.RecordCount > 0) Then
Set oApp = CreateObject("Excel.Application")
With oApp
.Workbooks.Add
For iCol = 0 To rs.Fields.Count - 1
.Cells(iRowBase, iColBase + iCol) = rs(iCol).Name
Select Case rs(iCol).Name
Case "グループ"
iGroupColNumber = iCol + 1
Case "仕入額"
iSubtotalColNumber = iCol + 1
End Select
Next
sColS = exColumnString(iColBase + 0)
.Range(sColS & iRowBase + 1).CopyFromRecordset rs
sColE = exColumnString(iColBase + rs.Fields.Count - 1)
sTmp = sColS & iRowBase & ":" & sColE & iRowBase + rs.RecordCount
.Range(sTmp).subtotal iGroupColNumber, -4157, iSubtotalColNumber
.Columns.EntireColumn.AutoFit
.Cells(1, 1).select
.Visible = True
.UserControl = True
End With
Set oApp = Nothing
End If
rs.Close
End Sub
Private Sub Form_Close()
DoCmd.OpenForm "F_MENU"
End Sub
フォーム「F5」の作成）
フォーム「F4」をコピーします。
CopyFromRecordset ではセルの書式まで面倒は見てくれないようです。
そこで、項目名（表の１行目）を作っている時に、列に対して書式を設定するようにします。
フォーム「F4」から変更した部分（区画）は以下
For iCol = 0 To rs.Fields.Count - 1
.Cells(iRowBase, iColBase + iCol) = rs(iCol).Name
sTmp = ""
Select Case rs(iCol).Name
Case "グループ"
iGroupColNumber = iCol + 1
Case "コード"
sTmp = "@"
Case "仕入額"
sTmp = "#,##0_ "
iSubtotalColNumber = iCol + 1
Case "前年比"
sTmp = "0%"
End Select
If (Len(sTmp) > 0) Then
sColS = exColumnString(iColBase + iCol)
.Columns(sColS & ":" & sColS).NumberFormatLocal = sTmp
End If
Next
フォーム「F6」の作成）
フォーム「F5」をコピーします。
フォーム「F4」「F5」では、レコードセットの項目並びを指定していたわけですが、順に関係ないように処理を記述したつもりでいるので、どんな表になるのか見てみます。
SELECT 部分を * に書き換えただけです。
後は、処理するレコード数等をみて、どの処理が適当なのか判断するのでしょうか。
サンプルは以下（ファイル名に意図はありません）
qa5736557kai_2007.zip (Access 2007 形式)
qa5736557kai_2003.zip (Access 2002 - 2003 形式)
qa5736557kai_2000.zip (Access 2000 形式)
2007 以外の形式は、2007 保存時に変換 & 各バージョンで動作確認 & 最適化
メニューフォーム「F_MENU」の作成）
非連結のフォームとして作ります。
オプショングループ「op1」をトグルボタン（値：１〜７）で作成します。
既定値は設定しません。
不要な「レコードセレクタ」「移動ボタン」は「いいえ」とし、ポップアップを「はい」とします。
それなりに見栄えを整えた後、オプショングループの「クリック時」にフォームの起動処理等を記述していきます。
VBAで記述した内容は以下
Private Sub op1_Click()
Dim sName As String
Select Case Me.op1
Case 1: sName = "F1"
Case 2: sName = "F2"
Case 3: sName = "F3"
Case 4: sName = "F4"
Case 5: sName = "F5"
Case 6: sName = "F6"
Case 7: sName = "F7"
End Select
DoCmd.OpenForm sName
DoCmd.Close acForm, Me.Name, acSaveNo
End Sub
フォーム「F1」の作成）
Excel への自力出力例（ベタ） の記述ミスを修正し、フォームの「閉じる時」にメニューを起動する処理を追加します。
追加した内容は以下
Private Sub Form_Close()
DoCmd.OpenForm "F_MENU"
End Sub
フォーム「F2」の作成）
フォーム「F1」をコピーし、SUM / SUMIF 作成部分を、SUBTOTAL を使用するように変更します。
また、小計部分に、小計をした名称を付加するように処理を追加します。
なお、フォーム「F1」で SUM を記述したセルには書式を設定しませんでしたが、SUBTOTAL を設定するセルの書式はチャンと設定しておきます。
（何故なんでしょう、違いがわかりません。Excelは難しぃ）
VBAでの記述内容は以下
Const SYOUKEI = "小計"
Dim sTitle As String
Private Function exColumnString(iNum As Long) As String
Dim sS As String
Dim i As Long
Dim iBase As Integer
sS = ""
i = iNum
iBase = Asc("A")
While (i > 0)
If (i > 26) Then
sS = Chr(iBase + ((i - 1) Mod 26)) & sS
i = Int((i - 1) / 26)
Else
sS = Chr(iBase + i - 1) & sS
i = -1
End If
Wend
exColumnString = sS
End Function
Private Sub SetMerge(oApp As Object, iRowS As Long, iRowE As Long, iColS As Long, iColE As Long)
Dim sS As String
Dim sE As String
sS = exColumnString(iColS)
sE = exColumnString(iColE)
oApp.Range(sS & iRowS & ":" & sE & iRowE).Merge
End Sub
Private Sub MergeSyoukei(oApp As Object, iRow As Long, iColS As Long, iColE As Long)
oApp.Cells(iRow, iColS) = SYOUKEI & " (" & Mid(sTitle, 2) & ")"
Call SetMerge(oApp, iRow, iRow, iColS, iColE)
End Sub
Private Sub SetSubtotal(oApp As Object, iRow As Long, iRowS As Long, iCol As Long)
Dim sTmp As String
sTmp = "=SUBTOTAL(9,R[-" & iRow - iRowS & "]C:R[-1]C)"
With oApp
.Cells(iRow, iCol).NumberFormatLocal = "#,##0_ "
.Cells(iRow, iCol).FormulaR1C1 = sTmp
End With
End Sub
Private Sub btn1_Click()
Dim rs As New ADODB.Recordset
Dim iGsave As Long
Dim oApp As Object
Dim iRowStart As Long
Dim iRow As Long
Const iRowBase = 3
Const iColBase = 2
rs.Source = "SELECT * FROM T1 ORDER BY グループ, コード ;"
rs.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
If (Not rs.EOF) Then
Set oApp = CreateObject("Excel.Application")
With oApp
.Workbooks.Add
iRow = iRowBase
.Cells(iRow, iColBase + 0) = "グループ"
.Cells(iRow, iColBase + 1) = "コード"
.Cells(iRow, iColBase + 2) = "名称"
.Cells(iRow, iColBase + 3) = "仕入額"
.Cells(iRow, iColBase + 4) = "前年比"
iGsave = -999999
While (Not rs.EOF)
iRow = iRow + 1
If (iGsave <> rs("グループ")) Then
If (iRow <> iRowBase + 1) Then
Call SetMerge(oApp, iRowStart, iRow - 1, iColBase + 0, iColBase + 0)
Call MergeSyoukei(oApp, iRow, iColBase + 0, iColBase + 2)
Call SetSubtotal(oApp, iRow, iRowStart, iColBase + 3)
iRow = iRow + 1
End If
iRowStart = iRow
iGsave = rs("グループ")
.Cells(iRow, iColBase + 0) = iGsave
sTitle = ""
End If
.Cells(iRow, iColBase + 1).NumberFormatLocal = "@"
.Cells(iRow, iColBase + 1) = rs("コード")
.Cells(iRow, iColBase + 2) = rs("名称")
sTitle = sTitle & "," & rs("名称")
.Cells(iRow, iColBase + 3).NumberFormatLocal = "#,##0_ "
.Cells(iRow, iColBase + 3) = rs("仕入額")
.Cells(iRow, iColBase + 4).NumberFormatLocal = "0%"
.Cells(iRow, iColBase + 4) = rs("前年比")
rs.MoveNext
Wend
iRow = iRow + 1
Call SetMerge(oApp, iRowStart, iRow - 1, iColBase + 0, iColBase + 0)
Call MergeSyoukei(oApp, iRow, iColBase + 0, iColBase + 2)
Call SetSubtotal(oApp, iRow, iRowStart, iColBase + 3)
iRow = iRow + 1
.Cells(iRow, iColBase + 0) = "合計"
Call SetMerge(oApp, iRow, iRow, iColBase + 0, iColBase + 2)
Call SetSubtotal(oApp, iRow, iRowBase + 1, iColBase + 3)
.Columns.EntireColumn.AutoFit
.Cells(1, 1).select
.Visible = True
.UserControl = True
End With
Set oApp = Nothing
End If
rs.Close
End Sub
Private Sub Form_Close()
DoCmd.OpenForm "F_MENU"
End Sub
フォーム「F3」の作成）
１行づつ処理することは変更しないので、「F1」「F2」どちらでも良いのでコピー元にしたコピーをします。
Excelの SUBTOTAL メソッドを使用しますが、「F1」「F2」の様にグループ部分をセル結合しているとまともに動いてくれません。
そこで、セル結合処理部分は丸々削除。
SUBTOTAL メソッドに指定する集計列は、項目順を意識した代入を行っているのでわかりきっています。
この部分、今回記述したのは以下となります。
.Range(sTmp).subtotal 1, -4157, 4
の 1 と 4 の部分になります。
範囲指定する１列目に「グループ」があり、４列目「仕入額」が集計対象になります。
途中の -4157 は、Excel 記述で xlSum にあたるもので、VBEの参照設定で Excel を参照していれば xlSum 記述でOKです。
今回 Excel を参照設定していないので、-4157 を直接記述します。
追記：3/13
.Range(sTmp).subtotal 1, -4157, 4
の正式な指定は
.Range(sTmp).subtotal 1, -4157, Array(4)
の様ですが、動いたのでそのまま使っています。
（内部で、配列なのか判別されているのだと思います。動かなければ良いのに･･･）
VBAでの記述内容は以下
Private Function exColumnString(iNum As Long) As String
Dim sS As String
Dim i As Long
Dim iBase As Integer
sS = ""
i = iNum
iBase = Asc("A")
While (i > 0)
If (i > 26) Then
sS = Chr(iBase + ((i - 1) Mod 26)) & sS
i = Int((i - 1) / 26)
Else
sS = Chr(iBase + i - 1) & sS
i = -1
End If
Wend
exColumnString = sS
End Function
Private Sub btn1_Click()
Dim rs As New ADODB.Recordset
Dim oApp As Object
Dim iRowStart As Long
Dim iRow As Long
Dim sColS As String
Dim sColE As String
Dim sTmp As String
Const iRowBase = 3
Const iColBase = 2
rs.Source = "SELECT * FROM T1 ORDER BY グループ, コード ;"
rs.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
If (Not rs.EOF) Then
Set oApp = CreateObject("Excel.Application")
With oApp
.Workbooks.Add
iRow = iRowBase
.Cells(iRow, iColBase + 0) = "グループ"
.Cells(iRow, iColBase + 1) = "コード"
.Cells(iRow, iColBase + 2) = "名称"
.Cells(iRow, iColBase + 3) = "仕入額"
.Cells(iRow, iColBase + 4) = "前年比"
While (Not rs.EOF)
iRow = iRow + 1
.Cells(iRow, iColBase + 0) = rs("グループ")
.Cells(iRow, iColBase + 1).NumberFormatLocal = "@"
.Cells(iRow, iColBase + 1) = rs("コード")
.Cells(iRow, iColBase + 2) = rs("名称")
.Cells(iRow, iColBase + 3).NumberFormatLocal = "#,##0_ "
.Cells(iRow, iColBase + 3) = rs("仕入額")
.Cells(iRow, iColBase + 4).NumberFormatLocal = "0%"
.Cells(iRow, iColBase + 4) = rs("前年比")
rs.MoveNext
Wend
sColS = exColumnString(iColBase + 0)
sColE = exColumnString(iColBase + 4)
sTmp = sColS & iRowBase & ":" & sColE & iRow
.Range(sTmp).subtotal 1, -4157, 4
.Columns.EntireColumn.AutoFit
.Cells(1, 1).select
.Visible = True
.UserControl = True
End With
Set oApp = Nothing
End If
rs.Close
End Sub
Private Sub Form_Close()
DoCmd.OpenForm "F_MENU"
End Sub
Excel の SUBTOTALメソッドを使用するのなら、１行１行自力で展開せずに、CopyFromRecordset を使った方が記述が少なくなって、しかも速く処理できるのでは？と思ってしまいます。
では、CopyFromRecordset を使って見よう･･･ということに。
フォーム「F7」の作成）
CopyFromRecordset を使用した単純な例として、フォーム「F7」を用意しました。
この実行結果は、単純にテーブル「T1」をメニュー等でExcelへエクスポートしたものと同じになります。
質問でよく、エクスポートした後で書式を変えたい、とか
エクスポートした後で、あるセルに情報を追加したい、とか
ありますが、
エクスポートした後で、Excelを起動して、開いて･･･という処理は記述すれば記述できないことはありませんが、
開いた時にエクスポートが終了している保証はないと思います。
こういう時には、自力で処理を記述した方が確かなような気がします。
VBAでの記述内容は以下
Private Sub btn1_Click()
Dim rs As New ADODB.Recordset
Dim oApp As Object
Dim iCol As Long
rs.Source = "SELECT * FROM T1 ORDER BY グループ,コード ;"
rs.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
If (Not rs.EOF) Then
Set oApp = CreateObject("Excel.Application")
With oApp
.Workbooks.Add
For iCol = 0 To rs.Fields.Count - 1
.Cells(1, iCol + 1) = rs(iCol).Name
Next
.Range("A2").CopyFromRecordset rs
.Visible = True
.UserControl = True
End With
Set oApp = Nothing
End If
rs.Close
End Sub
Private Sub Form_Close()
DoCmd.OpenForm "F_MENU"
End Sub
フォーム「F4」の作成）
フォーム「F3」をコピーします。
レコードセットを得る時に * にしているので、項目順がわかりません。
（CopyFromRecordset を使うと得た項目順で作成されるので）
SELECT で項目順を指定するようにします。
また、１行１行処理していくわけではないので、レコード数が欲しくなります。
そこで、adOpenForwardOnly 部分を、adOpenStatic に変更しておきます。
（出来上がった表の最終行とかはExcelの○○を使えば得られるようですが･･･、わかってません）
レコードセットで得られる項目順は出来上がったわけですが、
.Range(sTmp).subtotal
で指定する列は固定ではなく、処理で求めておくようにします。
VBAでの記述内容は以下
Private Function exColumnString(iNum As Long) As String
Dim sS As String
Dim i As Long
Dim iBase As Integer
sS = ""
i = iNum
iBase = Asc("A")
While (i > 0)
If (i > 26) Then
sS = Chr(iBase + ((i - 1) Mod 26)) & sS
i = Int((i - 1) / 26)
Else
sS = Chr(iBase + i - 1) & sS
i = -1
End If
Wend
exColumnString = sS
End Function
Private Sub btn1_Click()
Dim rs As New ADODB.Recordset
Dim oApp As Object
Dim iGroupColNumber As Long
Dim iSubtotalColNumber As Long
Dim iCol As Long
Dim sColS As String
Dim sColE As String
Dim sTmp As String
Const iRowBase = 3
Const iColBase = 2
rs.Source = "SELECT グループ,コード,名称,仕入額,前年比 FROM T1 ORDER BY グループ,コード ;"
rs.Open , CurrentProject.Connection, adOpenStatic, adLockReadOnly
If (rs.RecordCount > 0) Then
Set oApp = CreateObject("Excel.Application")
With oApp
.Workbooks.Add
For iCol = 0 To rs.Fields.Count - 1
.Cells(iRowBase, iColBase + iCol) = rs(iCol).Name
Select Case rs(iCol).Name
Case "グループ"
iGroupColNumber = iCol + 1
Case "仕入額"
iSubtotalColNumber = iCol + 1
End Select
Next
sColS = exColumnString(iColBase + 0)
.Range(sColS & iRowBase + 1).CopyFromRecordset rs
sColE = exColumnString(iColBase + rs.Fields.Count - 1)
sTmp = sColS & iRowBase & ":" & sColE & iRowBase + rs.RecordCount
.Range(sTmp).subtotal iGroupColNumber, -4157, iSubtotalColNumber
.Columns.EntireColumn.AutoFit
.Cells(1, 1).select
.Visible = True
.UserControl = True
End With
Set oApp = Nothing
End If
rs.Close
End Sub
Private Sub Form_Close()
DoCmd.OpenForm "F_MENU"
End Sub
フォーム「F5」の作成）
フォーム「F4」をコピーします。
CopyFromRecordset ではセルの書式まで面倒は見てくれないようです。
そこで、項目名（表の１行目）を作っている時に、列に対して書式を設定するようにします。
フォーム「F4」から変更した部分（区画）は以下
For iCol = 0 To rs.Fields.Count - 1
.Cells(iRowBase, iColBase + iCol) = rs(iCol).Name
sTmp = ""
Select Case rs(iCol).Name
Case "グループ"
iGroupColNumber = iCol + 1
Case "コード"
sTmp = "@"
Case "仕入額"
sTmp = "#,##0_ "
iSubtotalColNumber = iCol + 1
Case "前年比"
sTmp = "0%"
End Select
If (Len(sTmp) > 0) Then
sColS = exColumnString(iColBase + iCol)
.Columns(sColS & ":" & sColS).NumberFormatLocal = sTmp
End If
Next
フォーム「F6」の作成）
フォーム「F5」をコピーします。
フォーム「F4」「F5」では、レコードセットの項目並びを指定していたわけですが、順に関係ないように処理を記述したつもりでいるので、どんな表になるのか見てみます。
SELECT 部分を * に書き換えただけです。
後は、処理するレコード数等をみて、どの処理が適当なのか判断するのでしょうか。
サンプルは以下（ファイル名に意図はありません）
qa5736557kai_2007.zip (Access 2007 形式)
qa5736557kai_2003.zip (Access 2002 - 2003 形式)
qa5736557kai_2000.zip (Access 2000 形式)
2007 以外の形式は、2007 保存時に変換 & 各バージョンで動作確認 & 最適化
- 関連記事
- チェックボックスを使った絞込検索 (12/30)
- データシート形式サブフォームのExcel出力 (12/07)
- 日付入力支援 (12/20)
- 【帳票フォーム＋サブの構成】ｘ２（ネストはどうよ その２） (04/04)
- サブフォームのデータシート表示で項目表示/非表示 (12/04)
- 今日だから、【帳票フォーム＋サブの構成】ｘ２（ネストはどうよ） (04/01)
- 拡大鏡？もどきのクラス化 (08/09)
- 拡大鏡？もどき (08/08)
- 抽出条件の羅列 (08/12)
- サブフォームの切り替えポン＋α (08/04)
- ログイン者ごとの権限による動作の模索 (01/17)
- パラメータクエリでレコードセットを得る（DAO/ADO） (08/02)
- コントロールのイベント発生確認＋α (04/12)
2010/03/12
Category: 更新待ち旧記事
« Excel への自力出力例（横計算式挿入）
Excel への自力出力例（ベタ） »
この記事に対するコメント
トラックバック
| h o m e |