皆さん、おはようございます。
QA通信編集員です。
今日もとても気持ちいいですね。
天気が良いとテンションが50％増しです。逆に雨は、50％減ですが...。
今日は、電車で移動しながら、この記事を書いています。といっても、新幹線などでゆっくり移動中って訳ではなく、地下鉄移動中に慌ただしく書いています。
「他に時間があるだろう！」とか思われますよね。
そうなんですよね、たぶん、他に時間を取ろうと思えば、取れるとは思うのですが、ボクは、勝手に空き時間休暇制度(?)を導入しているので、比較的に空いている時間が無いんですよねぇ...。空き時間休暇制度って、ホントにちょっとした空き時間だけが休暇で、それ以外は、全部仕事って制度を勝手に決めてるんです。
で、その空き時間でQA通信を書いているって感じなんです。
なので、土日だろうが、平日の真昼間だろうが、真夜中だろうが、このQA通信を書いているんですけどね。
さてさて、本日は、前回の続きで、実際に集計処理をしちゃいましょうってネタです。
集計処理といっても、大した話ではありません。要は、リストから個数を抜き出して、表にしちゃいましょうってコトです。
良く関数を使って、「=COUNTIF(xx:xx,"○")」とか、「=COUNTA(xx:xx)」とか書きますよね？
これと同じ処理を行います。しかも、自動で。
コードを見る前に、ちょっと仕様を確認しましょう。
ここでは、以下の3つのシートを使います。
- データが入っているシート
- 集計値を出力するシート
- 項目名が記載されているシート
集計する際に、問題になるのが、リスト内には存在しない項目名です。
もちろん、リスト内に存在しない項目名は必要ないという場合もありますが、集計する際には、その項目が、0件であるということも重要な情報となります。このため、「項目名が記載されているシート」に、すべての項目名を記載しておき、そこから項目名を取りだそうというものです。
先頭の行には、項目数が入っており、次には、「データが入っているシート」内でのカラム名、項目名と続きます。まぁ、このあたりはプログラムの作り方次第なので、応用して作りなおして貰えればと思います。
「集計値を出力するシート」は、先にデータが存在している可能性もありますので、最初にシート内のデータを削除します。これは、各パラメータが変更されても、それに対応出来るようにする意味も込めています。なお、集計自体は、Excelの集計関数であるCOUNTIFを使用します。
最後に、集計した表からグラフ（ドーナツ型）を作成します。通常、グラフを作成すると、0件のデータも表示してしまいますが、グラフ内では、この0件のデータを表示させてしまうと、ごちゃごちゃしてしまいますので、0件データは削除するようにします。
たったこれだけです。
手作業では、グラフの作成にちょっと手間がかかるかも知れないので、5分から10分ぐらいの作業ですね。ただ、多くのデータの集計を行い、グラフを作成する作業をすると、すぐに1時間ぐらいの作業時間になってしまうでしょうね。
それではさっそくそのコードを見てみましょう。
前回のOKボタン押下時に呼び出しているTallyDataという関数です。
ちょっと長いですが、ご容赦下さい。
|
‘ strNameには、集計データを作成する項目が指定されています。
'
Sub TallyData(strName As String)
'--------------------------------------------------------------------
' 該当項目の検索
' 各種項目リストより、該当する項目の箇所を特定する
'--------------------------------------------------------------------
Dim i As Integer
Dim iMaxRow As Integer, iMaxCol As Integer
Dim iCol As Integer, iRow As Integer
Dim iCnt As Integer
Dim strColName As String
' 「項目名が記載されているシート」をアクティブにします。
Sheets(SHEET_ITEM_LIST).Activate
iMaxCol = ActiveSheet.UsedRange.Columns.Count
iCol = -1
' SHEET_IT_START_COLには、2が入っています。
For i = SHEET_IT_START_COL To iMaxCol
' SHEET_IT_TITLE_ROWには、3が入っています。
' 先のシートでのタイトル名を比較し、合致する場合に、その項目の情報を取得します。
If (StrComp(Cells(SHEET_IT_TITLE_ROW, i).Value, strName) = 0) Then
iCol = i ' 場所
iCnt = Cells(SHEET_IT_COUNT_ROW, i).Value ' 項目名個数
strColName = Cells(SHEET_IT_COLNAME_ROW, i).Value ' カラム名
End If
Next i
' 該当する項目が見つからない場合には、エラーメッセージを表示して終了します。
'
If (iCol < 0) Then
MsgBox "該当する項目が見つけられません。" & Chr(13) & _
"「" & SHEET_ITEM_LIST & "」と「" & gstrSheetDataList & "」の" & Chr(13) & _
"項目名が合致していない可能性があります。" & Chr(13) & Chr(13) & _
"各シートの項目名を確認して下さい。", _
vbOKOnly + vbExclamation, _
"項目が見つからない"
Exit Sub
End If
'--------------------------------------------------------------------
' パラメータ取得
'--------------------------------------------------------------------
Dim strHeader As String
' SETTING_TALLY_HEADERには、「集計－」が入っています。
strHeader = GetParam(SETTING_TALLY_HEADER)
' 指定されているシート（「集計値を出力するシート」）をアクティブにする
Dim strTitle As String
strTitle = strHeader & strName
Sheets(strTitle).Activate
'--------------------------------------------------------------------
' 削除処理
' 表作画域およびグラフを削除します。
'--------------------------------------------------------------------
iMaxRow = ActiveSheet.UsedRange.Rows.Count
iMaxCol = ActiveSheet.UsedRange.Columns.Count
If (iMaxRow > SHEET_TALLY_START_ROW) Then
Range(Cells(1, 1), Cells(iMaxRow, iMaxCol)).Select
Selection.Delete Shift:=xlUp
End If
If (ActiveSheet.ChartObjects.Count > 0) Then
Application.DisplayAlerts = False
ActiveSheet.ChartObjects.Delete ' グラフ削除
Application.DisplayAlerts = True
End If
'--------------------------------------------------------------------
' タイトル欄作成
'--------------------------------------------------------------------
ActiveSheet.Cells(1, 1).Value = strName
ActiveSheet.Cells(1, 2).Value = "件数"
Range(Cells(1, 1), Cells(1, 2)).Select
' Font設定
With Selection.Font
.Name = "ＭＳ Ｐゴシック"
.Size = 14
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
End With
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
'--------------------------------------------------------------------
' 各項目作成
' すべての項目を書き出し、対応する件数を表示します。
' このとき、単純な集計であれば、COUNTIF関数を使用しますが、
' 複数選択時には処理が異なるため、カウントアップした数値を
' 書き出します。
'--------------------------------------------------------------------
Dim strArea As String
strArea = "$" & strColName & "$2:$" & strColName & "$" & _
Sheets(gstrSheetDataList).UsedRange.Rows.Count
For i = 0 To iCnt
iRow = SHEET_TALLY_START_ROW + i ' 行番号
'----------------------------------------------------------------
' 各項目値の設定
'----------------------------------------------------------------
Dim strItem As String
Dim strValue As String
If (i < iCnt) Then
strItem = Sheets(SHEET_ITEM_LIST).Cells(SHEET_IT_START_ROW + i, iCol).Value
strValue = "=COUNTIF(" & gstrSheetDataList & "!" & strArea & ",A" & iRow & ")"
Else
Selection.Font.Size = 14
strItem = "Total"
strValue = "=SUM(B" & SHEET_TALLY_START_ROW & ":B" & iCnt + SHEET_TALLY_START_ROW - 1 & ")"
End If
ActiveSheet.Cells(iRow, 1).Value = strItem
ActiveSheet.Cells(iRow, 2).Value = strValue
Next i
' 作表後、改めてサイズを取得
iMaxRow = ActiveSheet.UsedRange.Rows.Count
iMaxCol = ActiveSheet.UsedRange.Columns.Count
'--------------------------------------------------------------------
' 罫線作画
'--------------------------------------------------------------------
Range(Cells(1, 1), Cells(iMaxRow, iMaxCol)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.Weight = xlThin
End With
'--------------------------------------------------------------------
' グラフ作成
' 作表後、必ずグラフを作成します。
'--------------------------------------------------------------------
Charts.Add
ActiveChart.ChartType = xlDoughnut ' ドーナツ型のグラフ
Dim strSourceArea As String
strSourceArea = "A1:" & "B" & iMaxRow – 1
ActiveChart.SetSourceData Source:=Sheets(strTitle).Range(strSourceArea), PlotBy:=xlColumns
ActiveChart.Location where:=xlLocationAsObject, Name:=strTitle
' すでにグラフタイトルがある場合には、グラフタイトルを削除します。
If (ActiveChart.HasTitle = True) Then
ActiveChart.ChartTitle.Select
Selection.Delete
End If
' データラベルの設定
ActiveChart.SeriesCollection(1).Select
ActiveChart.SeriesCollection(1).ApplyDataLabels
ActiveChart.SeriesCollection(1).DataLabels.Select
Selection.ShowPercentage = True
Selection.ShowValue = False
Selection.ShowCategoryName = True
ActiveChart.ChartGroups(1).DoughnutHoleSize = 30
ActiveChart.Legend.Select
Selection.Delete
'--------------------------------------------------------------------
' グラフ内テキストの処理
' グラフ内のテキストで、0.00%の項目は、削除します。
' それ以外のテキストは残し、フォーマットを設定します。
'--------------------------------------------------------------------
Dim pts As Points
Set pts = ActiveChart.SeriesCollection(1).Points
Dim str As String
Dim iPos As Integer
For i = 1 To pts.Count
pts(i).DataLabel.NumberFormat = "#0.00%"
str = pts(i).DataLabel.Text
iPos = InStr(1, str, "0.00%", vbTextCompare)
If (iPos <> 0) Then
pts(i).DataLabel.Delete
End If
Next i
' A1選択（カーソル位置を設定）
ActiveSheet.Range("A1").Select
End Sub
|
これで、集計した表とグラフの作成が出来ます。
ちょっと冗長になっている部分もあるとは思いますが、ご勘弁を...。
もっと他にも体裁を整えるコードなどもあったのですが、省略させてもらいました。
ご質問などあれば、是非、お聞かせ下さい。（ご質問は、こちらから）
