Excel への自力出力例(行・縦計算式挿入)
回答での事前確認をしていたのですが、回答には使わなくなったので・・・
せっかくだし・・・・
過去の記事にも似通ったものがありましたが、それは置いといて・・・
ユニオンクエリ等を使って、「本年実績」「前年実績」が「商品」別に各店単位で見られるようになっています。
図を見た方が説明は楽という事で・・・

「商品」単位で「前年比」を各店ごとに付加したい。
また、前年比の数値部分を赤色表示したい。
図を見た方が説明は楽という事で・・・

「商品」単位で「前年比」を各店ごとに付加したい。
また、前年比の数値部分を赤色表示したい。
回答したのですが、以下が伝わっていれば良いのですが
・1つのフィールドに複数の書式(今回は、通貨とパーセント)は設定できなかったかと
・UNION する時に、値をそれ用のものに文字列として変換、右詰になるように固定長に(左に空白埋めて)
・部分的に文字の色を変更するのはできなかったかと・・・(クエリでの事・・・)
よって、いっそのこと出力先をExcel にして、出来上がった部分を CopyFromRecordset で転記後、
前年比行を追加して、計算式を埋め込めば・・・・
今回のサンプルは、
この前年比行を追加して、計算式を埋め込む、文字色を赤に、+罫線
の例になるかと思います。
文字の色変えは、フォームを使えば条件付き書式で可能ですが・・・・・クエリで・・・ということで
(出力先を Excel へ・・・・っていうのも、突拍子もない事ですけど・・・・)
基本となるテーブル、クエリを作っていきます。



テーブルは、「T商品」「T店」と「T売上」の3つ
「T商品」のフィールドは、「商品ID」「商品名」の2つ
「T店」のフィールドは、「店ID」「店名」の2つ
「T売上」のフィールドは、「an」(オートナンバ)と
「売上日」「商品ID」「店ID」「売上」「更新日時」「備考」の7つ
「商品ID」「店ID」部分は、他のテーブルをルックアップし、「名」の方を表示するように
サンプルデータとして、2010/2011/2012 年のデータを「商品」「店」ごとに2件
クエリとして、
「Q_売上本年」「Q_売上前年」「Q_売上前年比」「Q_単なるUNION」「Q_クロス集計」の5つと
「Q_単なるUNION改」「Q_クロス集計改」の2つ
後者の2つは、表示する「売上計」「前年比」部分を文字列に変換したもの・・・
(1つのフィールド内で書式を複数使いたいための苦肉の策)
表示を確認していきますが、久しぶりに用意したメニュー用フォーム「F_MENU」を起動します。
(「・・・改」となっているクエリは直接確認します)
クエリとして記述した内容は、次の通りです。
「Q_売上本年」
SELECT T商品.商品名, T店.店名, Sum(T売上.売上) AS 売上計
FROM (T売上 INNER JOIN T店 ON T売上.店ID=T店.店ID) INNER JOIN T商品 ON T売上.商品ID=T商品.商品ID
WHERE ((Year([売上日])=Year(Date())))
GROUP BY T商品.商品名, T店.店名;
FROM (T売上 INNER JOIN T店 ON T売上.店ID=T店.店ID) INNER JOIN T商品 ON T売上.商品ID=T商品.商品ID
WHERE ((Year([売上日])=Year(Date())))
GROUP BY T商品.商品名, T店.店名;
「Q_売上前年」
SELECT T商品.商品名, T店.店名, Sum(T売上.売上) AS 売上計
FROM (T売上 INNER JOIN T店 ON T売上.店ID=T店.店ID) INNER JOIN T商品 ON T売上.商品ID=T商品.商品ID
WHERE ((Year([売上日])=Year(Date())-1))
GROUP BY T商品.商品名, T店.店名;
FROM (T売上 INNER JOIN T店 ON T売上.店ID=T店.店ID) INNER JOIN T商品 ON T売上.商品ID=T商品.商品ID
WHERE ((Year([売上日])=Year(Date())-1))
GROUP BY T商品.商品名, T店.店名;
「Q_売上前年比」
SELECT Q_売上本年.商品名, Q_売上本年.店名, Q_売上本年.売上計/Q_売上前年.売上計 AS 前年比
FROM Q_売上前年 INNER JOIN Q_売上本年 ON (Q_売上前年.商品名=Q_売上本年.商品名) AND (Q_売上前年.店名=Q_売上本年.店名);
FROM Q_売上前年 INNER JOIN Q_売上本年 ON (Q_売上前年.商品名=Q_売上本年.商品名) AND (Q_売上前年.店名=Q_売上本年.店名);
「Q_単なるUNION」
SELECT 商品名, Choose(S,'本年実績','前年実績','前年比') AS 実績, 店名, 売上計
FROM (SELECT 1 AS S, * FROM Q_売上本年
UNION ALL
SELECT 2 AS S, * FROM Q_売上前年
UNION ALL
SELECT 3 AS S, * FROM Q_売上前年比) AS Q1
ORDER BY 商品名, 店名, S;
FROM (SELECT 1 AS S, * FROM Q_売上本年
UNION ALL
SELECT 2 AS S, * FROM Q_売上前年
UNION ALL
SELECT 3 AS S, * FROM Q_売上前年比) AS Q1
ORDER BY 商品名, 店名, S;
ここで悩んだんですが、「本年実績」「前年実績」「前年比」をどの段階で入れ込もうか・・・
SELECT 商品名, 実績, 店名, 売上計
FROM (SELECT '本年実績' AS 実績, * FROM Q_売上本年
UNION ALL
SELECT '前年実績' AS 実績, * FROM Q_売上前年
UNION ALL
SELECT '前年比' AS 実績, * FROM Q_売上前年比) AS Q1
ORDER BY 商品名, 店名, 実績;
FROM (SELECT '本年実績' AS 実績, * FROM Q_売上本年
UNION ALL
SELECT '前年実績' AS 実績, * FROM Q_売上前年
UNION ALL
SELECT '前年比' AS 実績, * FROM Q_売上前年比) AS Q1
ORDER BY 商品名, 店名, 実績;
並び替えする前に上記の様に入れてしまうと、
「商品名」「店名」で並んだあと「前年実績」「前年比」「本年実績」の順になってしまうので
並び替えは数字で行って、その数字に対応するように文字列に置換え・・・・としました。
以降の記述も同様です。
「Q_クロス集計」
TRANSFORM First(売上計) AS 値
SELECT 商品名, Choose(S,'本年実績','前年実績') AS 実績
FROM (SELECT 1 AS S, * FROM Q_売上本年
UNION ALL
SELECT 2 AS S, * FROM Q_売上前年) AS Q1
GROUP BY 商品名, S
PIVOT 店名;
SELECT 商品名, Choose(S,'本年実績','前年実績') AS 実績
FROM (SELECT 1 AS S, * FROM Q_売上本年
UNION ALL
SELECT 2 AS S, * FROM Q_売上前年) AS Q1
GROUP BY 商品名, S
PIVOT 店名;
「Q_単なるUNION改」
SELECT Q1.商品名, Choose(S,'本年実績','前年実績','前年比') AS 実績, String(15-len(文字),' ') & 文字 AS 売上計
FROM (
SELECT 1 AS S, 商品名, 店名, Format(売上計,"\\#,##0") AS 文字 FROM Q_売上本年
UNION ALL
SELECT 2 AS S, 商品名, 店名, Format(売上計,"\\#,##0") FROM Q_売上前年
UNION ALL
SELECT 3 AS S, 商品名, 店名, Format(前年比,"0.0%") FROM Q_売上前年比) AS Q1
ORDER BY Q1.商品名, Q1.店名, Q1.S;
FROM (
SELECT 1 AS S, 商品名, 店名, Format(売上計,"\\#,##0") AS 文字 FROM Q_売上本年
UNION ALL
SELECT 2 AS S, 商品名, 店名, Format(売上計,"\\#,##0") FROM Q_売上前年
UNION ALL
SELECT 3 AS S, 商品名, 店名, Format(前年比,"0.0%") FROM Q_売上前年比) AS Q1
ORDER BY Q1.商品名, Q1.店名, Q1.S;
「Q_クロス集計改」
TRANSFORM First(String(13-Len(文字)," ") & 文字) AS 値
SELECT 商品名, Choose(S,'本年実績','前年実績','前年比') AS 実績
FROM (
SELECT 1 AS S, 商品名, 店名, Format(売上計,"\\#,##0") AS 文字 FROM Q_売上本年
UNION ALL
SELECT 2 AS S, 商品名, 店名, Format(売上計,"\\#,##0") FROM Q_売上前年
UNION ALL
SELECT 3 AS S, 商品名, 店名, Format(前年比,"0.0%") FROM Q_売上前年比) AS Q1
GROUP BY 商品名, S
PIVOT 店名;
SELECT 商品名, Choose(S,'本年実績','前年実績','前年比') AS 実績
FROM (
SELECT 1 AS S, 商品名, 店名, Format(売上計,"\\#,##0") AS 文字 FROM Q_売上本年
UNION ALL
SELECT 2 AS S, 商品名, 店名, Format(売上計,"\\#,##0") FROM Q_売上前年
UNION ALL
SELECT 3 AS S, 商品名, 店名, Format(前年比,"0.0%") FROM Q_売上前年比) AS Q1
GROUP BY 商品名, S
PIVOT 店名;
なお、上記テーブル、クエリを表示した後、フォーム内「テーブル・クエリの表示確認」を
クリックすると、表示は消えます。
(エラー処理は入れていないので、見映え等変更していた場合は「キャンセル」は選ばないで・・・)
ここからが、一応メインの Excel への出力になります。
「単なる出力+α」をクリックすると、以下の様な感じで Excel が表示されると思います。

クエリ「Q_クロス集計」を使用し、単に CopyFromRecordset で出力したもの(図の上側)
単に CopyFromRecordset で出力しただけでは数値部分が通貨表示にならないので書式を設定
VBA 記述したのは以下
Private Sub btn11_Click()
Dim rs As New ADODB.Recordset
Dim oApp As Object
Dim i As Integer
Const CSTART_RANGE As String = "B2" ' Excel 上書き出し位置
Const CQNAME As String = "Q_クロス集計" ' クエリ名
Const xlCellTypeLastCell = 11
rs.Open CQNAME, CurrentProject.Connection, adOpenStatic, adLockReadOnly
If (Not rs.EOF) Then
Set oApp = CreateObject("Excel.Application")
With oApp
.Workbooks.Add
' レコードセットの転記
With .Range(CSTART_RANGE)
For i = 0 To rs.Fields.Count - 1
.Offset(, i) = rs.Fields(i).Name
Next
.Offset(1).CopyFromRecordset rs
.Offset(.CurrentRegion.Rows.Count + 3).Select
End With
With .ActiveCell
For i = 0 To rs.Fields.Count - 1
.Offset(, i) = rs.Fields(i).Name
Next
rs.MoveFirst
.Offset(1).CopyFromRecordset rs
With oApp.Range(.Offset(1, 2), oApp.Cells.SpecialCells(xlCellTypeLastCell))
.NumberFormatLocal = "\#,##0;\-#,##0"
End With
End With
.Range("A1").Select
.Visible = True
End With
Set oApp = Nothing
End If
rs.Close
End Sub
Dim rs As New ADODB.Recordset
Dim oApp As Object
Dim i As Integer
Const CSTART_RANGE As String = "B2" ' Excel 上書き出し位置
Const CQNAME As String = "Q_クロス集計" ' クエリ名
Const xlCellTypeLastCell = 11
rs.Open CQNAME, CurrentProject.Connection, adOpenStatic, adLockReadOnly
If (Not rs.EOF) Then
Set oApp = CreateObject("Excel.Application")
With oApp
.Workbooks.Add
' レコードセットの転記
With .Range(CSTART_RANGE)
For i = 0 To rs.Fields.Count - 1
.Offset(, i) = rs.Fields(i).Name
Next
.Offset(1).CopyFromRecordset rs
.Offset(.CurrentRegion.Rows.Count + 3).Select
End With
With .ActiveCell
For i = 0 To rs.Fields.Count - 1
.Offset(, i) = rs.Fields(i).Name
Next
rs.MoveFirst
.Offset(1).CopyFromRecordset rs
With oApp.Range(.Offset(1, 2), oApp.Cells.SpecialCells(xlCellTypeLastCell))
.NumberFormatLocal = "\#,##0;\-#,##0"
End With
End With
.Range("A1").Select
.Visible = True
End With
Set oApp = Nothing
End If
rs.Close
End Sub
ここで、再認識したのですが、CopyFromRecordset 後の rs は、EOF = True になっており、
再利用する時には rs.MoveFirst が必要ですが、adOpenForwardOnly 指定では、
2007 では動くようですが、2000 / 2003 ではエラーになりますね・・・
なので、adOpenStatic を指定していました。
上記に「前年比」を追加し、文字の色変え、書式設定、「比」の計算式盛り込み、+罫線
+見映えをチョコっと

この記述が以下
Private Sub btn12_Click()
Dim rs As New ADODB.Recordset
Dim oApp As Object
Dim i As Integer
Const CSTART_RANGE As String = "B2" ' Excel 上書き出し位置
Const CQNAME As String = "Q_クロス集計" ' クエリ名
Const xlCellTypeLastCell = 11
Const xlCenter = -4108
Const xlContinuous = 1
rs.Open CQNAME, CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
If (Not rs.EOF) Then
Set oApp = CreateObject("Excel.Application")
With oApp
.Workbooks.Add
' レコードセットの転記
With .Range(CSTART_RANGE)
For i = 2 To rs.Fields.Count - 1
.Offset(, i) = rs.Fields(i).Name
Next
.Offset(1).CopyFromRecordset rs
With oApp.Range(.Offset(1, 2), oApp.Cells.SpecialCells(xlCellTypeLastCell))
.NumberFormatLocal = "\#,##0;\-#,##0"
End With
.Offset(2, 1).Select
End With
' 前年比行の作成
While (.ActiveCell.Value <> "")
With .ActiveCell
.Offset(1).EntireRow.Insert
.Offset(1, -1) = .Offset(, -1)
.Offset(1) = "前年比"
With oApp.Range(.Offset(1, 1), .Offset(1, rs.Fields.Count - 2))
.Font.ColorIndex = 3
.NumberFormatLocal = "0.0%"
.FormulaR1C1 = "=IF(R[-1]C="""","""",R[-2]C/R[-1]C)"
End With
.Offset(3).Select
End With
Wend
' 見映え
With .Range(CSTART_RANGE)
With oApp.Range(.Offset(, 2), .Offset(, rs.Fields.Count - 1))
.HorizontalAlignment = xlCenter
End With
With oApp.Range(.Offset(, 1), oApp.Cells.SpecialCells(xlCellTypeLastCell))
.Borders.LineStyle = xlContinuous
.EntireColumn.ColumnWidth = 10
End With
.EntireColumn.AutoFit
End With
.Range("A1").Select
.Visible = True
End With
Set oApp = Nothing
End If
rs.Close
End Sub
Dim rs As New ADODB.Recordset
Dim oApp As Object
Dim i As Integer
Const CSTART_RANGE As String = "B2" ' Excel 上書き出し位置
Const CQNAME As String = "Q_クロス集計" ' クエリ名
Const xlCellTypeLastCell = 11
Const xlCenter = -4108
Const xlContinuous = 1
rs.Open CQNAME, CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
If (Not rs.EOF) Then
Set oApp = CreateObject("Excel.Application")
With oApp
.Workbooks.Add
' レコードセットの転記
With .Range(CSTART_RANGE)
For i = 2 To rs.Fields.Count - 1
.Offset(, i) = rs.Fields(i).Name
Next
.Offset(1).CopyFromRecordset rs
With oApp.Range(.Offset(1, 2), oApp.Cells.SpecialCells(xlCellTypeLastCell))
.NumberFormatLocal = "\#,##0;\-#,##0"
End With
.Offset(2, 1).Select
End With
' 前年比行の作成
While (.ActiveCell.Value <> "")
With .ActiveCell
.Offset(1).EntireRow.Insert
.Offset(1, -1) = .Offset(, -1)
.Offset(1) = "前年比"
With oApp.Range(.Offset(1, 1), .Offset(1, rs.Fields.Count - 2))
.Font.ColorIndex = 3
.NumberFormatLocal = "0.0%"
.FormulaR1C1 = "=IF(R[-1]C="""","""",R[-2]C/R[-1]C)"
End With
.Offset(3).Select
End With
Wend
' 見映え
With .Range(CSTART_RANGE)
With oApp.Range(.Offset(, 2), .Offset(, rs.Fields.Count - 1))
.HorizontalAlignment = xlCenter
End With
With oApp.Range(.Offset(, 1), oApp.Cells.SpecialCells(xlCellTypeLastCell))
.Borders.LineStyle = xlContinuous
.EntireColumn.ColumnWidth = 10
End With
.EntireColumn.AutoFit
End With
.Range("A1").Select
.Visible = True
End With
Set oApp = Nothing
End If
rs.Close
End Sub
まず、CopyFromRecordset した後に、数値部分を通貨表示に書式を設定します。
その後、「前年実績」に移動し、そこに文字が埋まっていたら、下に行を追加し、
商品名、前年比文字を埋めます。
追加した行の数値部分にあたるところに、文字色、パーセントの書式、計算式を埋め込みます。
次の「前年実績」があるはずところに移動し、処理を繰り返します。
後は見映え用に、店名部分を中央配置に、罫線引いて、セル幅揃えて・・・・
で最後に、「A1」を選んで、Excel を表示するように・・・・
サンプルは以下 | ||||||||||||
| ||||||||||||
※ ファイルは zip 形式 | ||||||||||||
※ 2007 以外は、2007 保存時に変換 & 各バージョンで動作確認 & 最適化 |
- 関連記事
-
- Excel VBA をやってみた その16 (2015/05/26)
- こんな感じ・・・ (2013/03/30)
- プニュンで割付け (2011/11/26)
- 変更した部分の背景色を変える (2011/07/03)
- Excel ファイルのプレビュー (2013/09/17)
- フォームを増殖させる (2014/02/03)
- ファイル名をください (2011/07/03)
- 検索用途コンボの4階層連携 (2014/07/06)
- Excelのハイパーリンク情報をインポートする (2015/02/26)
- 検索用途コンボの4階層連携 その2 (2014/07/12)
- サブフォームのFilter (2011/10/10)
- 採番する (2011/11/26)
- 出力項目指定の模索 (2013/04/06)
2012/10/09
Category: サンプルかな
TB: -- /
CM: 0
« Excel VBA をやってみた その5
Excel VBA をやってみた その4 »
この記事に対するコメント
| h o m e |