レポート用データとしては以下のものがある。
・グラフの種類と集計方法を注釈として書き出す。
・件数や%の高い順にソートしたデータ作成し、その項目を結合し、レポート用データとして書き出す。
・バブルチャートでは、次のデータを作成し、コメントデータを書き出す。
・・最終年がピークとなっている項目を集めて表として書き出す。
・・最終年が前年より増加している項目を集めて表として書き出す。
・・所定条件を満たす項目を集めて表として書き出す。
マクロのサンプルは以下のとおり。
Sub レポート用データ作成()
'
'レポート作成用として上位分類を書出す
'
'変数を宣言
Dim SHEETNAME01 As String, SHEETNAME02 As String
Dim NY11 As Long, NX11 As Integer, NY12 As Long, NX12 As Integer
Dim NY21 As Long, NX21 As Integer, NY22 As Long, NX22 As Integer
Dim y As Long, x As Integer, bny As Long, nxs1 As Integer, nxs2 As Integer
Dim nsheet1 As Integer, nsheet2 As Integer, keta As Integer, bword As String, flg As Integer
Dim k As Integer, m As Integer, n As Integer
'シート名称設定
dSHEETNAME1 = Array("一桁別円グラフ", "三桁別円グラフ", "四桁別円グラフ", "六桁別円グラフ")
nsheet1 = 4
dSHEETNAME2 = Array("一桁年別バブル", "三桁年別バブル", "四桁年別バブル", "六桁年別バブル")
nsheet2 = 4
'
'===========================
'各桁別円グラフ.の上位データをコピーする
'ただし合計行は除く
'===========================
For k = 0 To nsheet1 - 1
'処理範囲の行列数を取得
Sheets(dSHEETNAME1(k)).Select
Cells(1, 1).Select
ActiveCell.CurrentRegion.Select
NY11 = Selection.Rows.Count
NX11 = Selection.Columns.Count
If NY11 > 1 Then
If NY11 < 50 Then
'合計欄を見つける
For y = 2 To NY11
If Cells(y, 1) = "合計" Then
bny = y
Exit For
End If
Next y
'合計欄以降を除いてコピー
Range(Cells(1, 1), Cells(bny - 1, NX11)).Copy Destination:=Cells(1, NX11 + 4)
'処理範囲の行列数を取得
Sheets(dSHEETNAME1(k)).Select
Cells(1, NX11 + 4).Select
ActiveCell.CurrentRegion.Select
NY12 = Selection.Rows.Count
NX12 = Selection.Columns.Count
'コピー位置を設定
nxs1 = NX11 + 4
nxs2 = NX11 + 4 + NX12 - 1
'件数によりソート
Range(Cells(1, nxs1), Cells(NY12, nxs2)).Sort Key1:=Cells(1, nxs1 + 2), Order1:=xlDescending, Header:= _
xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin
'罫線を設定
Range(Cells(1, nxs1), Cells(NY12, nxs2)).Borders.LineStyle = xlContinuous
'カテゴリを順位別に書出し
bword = ""
' Cells(2, nxs2 + 1) = bword
For y = 2 To NY12
bword = bword & Cells(y, nxs1) & ":" & Cells(y, nxs1 + 1) & "、"
Next y
Cells(NY12 + 2, nxs1) = bword
'セル幅を設定
Cells(1, nxs1).Select
Selection.ColumnWidth = 13
'折返しなしに設定
Range(Cells(2, nxs1), Cells(NY12, nxs2)).Select
With Selection
.WrapText = False
End With
'
Cells(1, 1).Select
End If
End If
Next k
'
'============================
'バブルチャートのシートの上位データをコピー
'ただし合計行は除く
'============================
'コピー
For k = 0 To nsheet2 - 1
'処理範囲の行列数を取得
Sheets(dSHEETNAME2(k)).Select
Cells(1, 1).Select
ActiveCell.CurrentRegion.Select
NY11 = Selection.Rows.Count
NX11 = Selection.Columns.Count
If NX11 < 4 Then Exit For
If NY11 > 1 Then 'データが有れば
' If NY11 < 50 Then
'ヘッダをコピー
Cells(1, NX11 + 3) = Cells(1, 1)
Cells(1, NX11 + 4) = Cells(1, NX11 - 2)
'最終年にピークがきている課題データの第１列と最終年データをコピー
m = 1
For y = 2 To NY11 - 1
If Cells(y, NX11 - 2).Interior.ColorIndex > 1 Then
m = m + 1
Cells(m, NX11 + 3) = Cells(y, 1)
Cells(m, NX11 + 4) = Cells(y, NX11 - 2)
End If
Next y
'処理範囲の行列数を取得
Sheets(dSHEETNAME2(k)).Select
Cells(1, NX11 + 4).Select
ActiveCell.CurrentRegion.Select
bny = Selection.Rows.Count
'ヘッダを着色
Range(Cells(1, NX11 + 3), Cells(1, NX11 + 4)).Select
With Selection
.Interior.Color = RGB(150, 250, 100) '濃緑色に着色
End With
'データを黄色に着色.
For y = 2 To bny
Cells(y, NX11 + 4).Select
With Selection
.Interior.Color = RGB(250, 250, 100) '黄色に着色
End With
Next y
'セル幅設定
Columns(NX11 + 3).ColumnWidth = 15
Columns(NX11 + 4).ColumnWidth = 15
'
'合計欄を見つける
For y = 2 To NY11
If Cells(y, 1) = "合計" Then
bny = y
Exit For
End If
Next y
For x = 2 To NX11
If Cells(1, x) = "合計" Then
bnx = x
Exit For
End If
Next x
'縦合計行以降を除いてA列をコピー
Range(Cells(1, 1), Cells(bny - 1, 1)).Copy Destination:=Cells(1, NX11 + 7)
'縦合計行以降を除いて前年比%をコピー
Range(Cells(1, bnx + 1), Cells(bny - 1, bnx + 1)).Copy Destination:=Cells(1, NX11 + 8)
'縦合計行以降を除いて横合計をコピー
Range(Cells(1, bnx), Cells(bny - 1, bnx)).Copy Destination:=Cells(1, NX11 + 9)
'縦合計行以降を除いて各年データの値をコピー
' Range(Cells(1, 2), Cells(bny - 1, bnx - 1)).Copy
' Cells(1, NX11 + 10).PasteSpecial Paste:=xlValues
'処理範囲の行列数を取得
Sheets(dSHEETNAME2(k)).Select
Cells(1, NX11 + 7).Select
ActiveCell.CurrentRegion.Select
NY12 = Selection.Rows.Count
NX12 = Selection.Columns.Count
'コピー位置を設定
nxs1 = NX11 + 7
nxs2 = NX11 + 7 + NX12 - 1
'前年比%が無色のデータをクリア
If NX12 >= 3 Then
For y = 2 To NY12
If Cells(y, nxs1 + 1).Interior.Color = RGB(255, 255, 255) Then '無色ならばクリア
Range(Cells(y, nxs1), Cells(y, nxs2)).Clear
End If
Next y
'コードでソート
Range(Cells(1, nxs1), Cells(NY12, nxs2)).Sort Key1:=Cells(1, nxs1), Order1:=xlAscending, Header:= _
xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin
End If
'処理範囲の行列数を取得
Sheets(dSHEETNAME2(k)).Select
Cells(1, NX11 + 7).Select
ActiveCell.CurrentRegion.Select
NY12 = Selection.Rows.Count
NX12 = Selection.Columns.Count
'罫線を設定
Range(Cells(1, nxs1), Cells(NY12, nxs2)).Borders.LineStyle = xlContinuous
'カテゴリを順位別に書出し
bword = ""
' Cells(NY12 + 2, nxs1) = bword
For y = 2 To NY12
If Cells(y, nxs1 + 1) > 100 Then
bword = bword & "、" & Cells(y, nxs1)
Else
Exit For
End If
Next y
Cells(NY12 + 2, nxs1) = bword
'セル幅を設定
Cells(1, nxs1).Select
Selection.ColumnWidth = 13
'折返しなしに設定
Range(Cells(2, nxs1), Cells(NY12, nxs2)).Select
With Selection
.WrapText = False
End With
Cells(1, 1).Select
'
'=================================================
'最終年の件数が平均以上でかつピーク時の80%以上でかつ増加率が100%以上か
'または最終年の件数が平均以上でかつピーク時の95%以上のものを重要として書出す
'=================================================
'最終年と平均件数を算出
n = 0
ntot = 0
For y = 2 To NY11 - 1
If Cells(y, NX11 - 2) > 0 Then
n = n + 1
ntot = ntot + Cells(y, NX11 - 2)
End If
Next y
If n > 0 Then
navr = ntot / n
Else
navr = 0
End If
'平均件数書出し
Cells(NY11 + 2, NX11 - 2) = navr
'小数点以下１位に設定
Cells(NY11 + 2, NX11 - 2).Select
Selection.NumberFormatLocal = "0.0_ "
'ピーク時の件数書出し
nmax = 0
nx = 0
For y = 2 To NY11 - 1
For x = 2 To NX11 - 2
If Cells(y, x) > nmax Then
nmax = Cells(y, x)
nx = x
End If
Next x
If nx > 1 Then
Cells(y, NX11 + 1) = Cells(y, nx)
nmax = 0
End If
Next y
'ヘッダをコピー
Cells(1, nxs2 + 2) = Cells(1, 1)
Cells(1, nxs2 + 3) = Cells(1, NX11 - 2)
Cells(1, nxs2 + 4) = Cells(1, NX11)
'最終年の件数が平均以上でかつピーク時の80%以上でかつ増加率が100%以上か
'または最終年の件数が平均以上でかつピーク時の95%以上を書出す
n = 1
For y = 2 To NY11 - 1
If Cells(y, NX11 - 2) > navr Then '最終年の件数が平均以上
If Cells(y, NX11 - 2) > Cells(y, NX11 + 1) * 0.8 Then 'ピーク時の80%以上
If Cells(y, NX11) > 100 Then '増加率が100%以上
n = n + 1
Cells(n, nxs2 + 2) = Cells(y, 1)
Cells(n, nxs2 + 3) = Cells(y, NX11 - 2)
Cells(n, nxs2 + 4) = Cells(y, NX11)
Else 'または
If Cells(y, NX11 - 2) > Cells(y, NX11 + 1) * 0.95 Then 'ピーク時の95%以上
n = n + 1
Cells(n, nxs2 + 2) = Cells(y, 1)
Cells(n, nxs2 + 3) = Cells(y, NX11 - 2)
Cells(n, nxs2 + 4) = Cells(y, NX11)
End If
End If
End If
End If
Next y
'処理範囲の行列数を取得
Sheets(dSHEETNAME2(k)).Select
Cells(1, nxs2 + 3).Select
ActiveCell.CurrentRegion.Select
bny = Selection.Rows.Count
'ヘッダを着色
Range(Cells(1, nxs2 + 2), Cells(1, nxs2 + 4)).Select
With Selection
.Interior.Color = RGB(150, 250, 100) '濃緑色に着色
End With
'セル幅設定
Columns(nxs2 + 2).ColumnWidth = 15
Columns(nxs2 + 3).ColumnWidth = 10
Columns(nxs2 + 4).ColumnWidth = 10
'処理範囲の行列数を取得
Sheets(dSHEETNAME2(k)).Select
Cells(1, nxs2 + 2).Select
ActiveCell.CurrentRegion.Select
NY23 = Selection.Rows.Count
'コメントを追加
Cells(NY23 + 2, nxs2 + 2) = "最終年の件数が平均以上でかつピーク時の80%以上でかつ増加率が100%以上の課題"
Cells(NY23 + 3, nxs2 + 2) = "または最終年の件数が平均以上でかつピーク時の95%以上の課題"
'表内の件数データを標準形式に設定
Range(Cells(2, nxs2 + 3), Cells(NY11, nxs2 + 3)).Select
Selection.NumberFormatLocal = "G/標準"
'%欄を小数点以下１位に設定
Range(Cells(2, nxs2 + 4), Cells(NY11, nxs2 + 4)).Select
Selection.NumberFormatLocal = "0.0_ "
'ピーク件数のカラムをクリア
Columns(NX11 + 1).Clear
' End If
End If
Cells(1, 1).Select
Next k
'
'==============
'Cells(1, 1).Select
'MsgBox "終了しました"
'
End Sub