Sub SetData()
' 画面を初期化
Rows("1:19").Select
Selection.Delete Shift:=xlUp
' 列の選択状態を解除
Sheet1.Range("A1").Select
' 実行ボタンを生成
With ActiveSheet.Buttons.Add(Range("B5").Left, _
Range("B5").Top, _
Range("B5:D5").Width, _
Range("B5:D6").Height)
.Name = "btn"
.OnAction = "Sheet1.MakeMaxValueTable"
.Characters.Text = "exe"
End With
' テストデータを出力
Dim arr_id_data As Variant: arr_id_data = Array("e_01", "e_02", "e_03", "e_04", "e_05", "e_06", "e_07", "e_08", "e_09", "e_10")
Dim arr_val_data As Variant: arr_val_data = Array(1000, 1300, 800, 1100, 700, 1000, 2100, 1100, 500, 800)
For r = 0 To UBound(arr_id_data)
Cells(r + 9, 2).Value = arr_id_data(r)
Cells(r + 9, 3).Value = arr_val_data(r)
Next r
' ヘッダーを設定
Sheet1.Range("B8").Value = "ID"
Sheet1.Range("C8:C8").Value = "Value"
Sheet1.Range("E8").Value = "閾値"
' 閾値を設定
Sheet1.Range("E9").Value = 800
' *** 全体的な見た目の設定 ****
Call SetFormat(Sheet1, Sheet1.Range("B8:C8"), "id")
Call SetFormat(Sheet1, Sheet1.Range("B9:B18"), "id")
Call SetFormat(Sheet1, Sheet1.Range("C9:C18"), "val")
Call SetFormat(Sheet1, Sheet1.Range("E8:E8"), "id")
Call SetFormat(Sheet1, Sheet1.Range("E9:E9"), "val")
' フォーカスを所定の位置へ
Sheet1.Range("A1").Select
End Sub
' 最大値を抽出し強調表示する
Sub MakeMaxValueTable()
'画面初期化
' 条件付き書式をクリア
Dim ws As Worksheet
For Each ws In Worksheets
ws.Cells.FormatConditions.Delete
Next ws
' グラフをクリア
With Sheet1
' 実行結果出力範囲をクリア
.Rows("2:3").Clear
Dim r As Long
For r = .ChartObjects.Count To 1 Step -1
.ChartObjects(r).Delete
Next r
End With
'リストの値を取得して、配列に格納
Dim arr_ori As Variant: arr_ori = Sheet1.Range("B9:C18").Value
' 閾値を取得
Dim line_val As Long: line_val = Sheet1.Range("E9").Value
' 最大値を取得
Dim max_val As Long: max_val = Application.WorksheetFunction.Max(arr_ori)
' 最大値 <= 閾値は処理終了
If (max_val <= line_val) Then
Dim rc As Integer
rc = MsgBox("閾値は最大値より小さい値を設定してください。" & vbCrLf & "最大値:" & max_val, vbOKOnly + vbExclamation)
If rc = vbOK Then
Exit Sub
End If
End If
Dim i As Long
Dim arrayCount As Long: arrayCount = UBound(arr_ori, 1)
ReDim arr_ans(LBound(arr_ori, 2) To UBound(arr_ori, 2), 1 To UBound(arr_ori, 1))
' 閾値以上の値を抽出して、配列に再格納(行と列を入れ替えて格納する)
' j = 1で、IDを処理:IDに紐づく値が、閾値より大きい場合、IDを格納
' j = 2で、値を処理:閾値より大きい場合、値を格納
For j = LBound(arr_ori, 2) To UBound(arr_ori, 2)
Dim c As Long: c = 1
For i = LBound(arr_ori, 1) To UBound(arr_ori, 1)
If arr_ori(i, 2) > line_val Then
arr_ans(j, c) = arr_ori(i, j)
c = c + 1
End If
Next i
Next j
' 閾値より大きい値の個数を、最大列数としてRangeに設定
Dim clm As Long: clm = c
'再格納した配列をエクセルに出力
Sheet1.Range(Cells(2, 2), Cells(3, clm)).Value = arr_ans
' 最大値の設定
Dim fc As FormatCondition
' range・・・入れ子だと見辛いので、変数に格納
Dim tRng As Range: Set tRng = Sheet1.Range(Cells(3, 2), Cells(3, clm))
' 条件付き書式を生成・・・入れ子だと見辛いので、変数に格納(.Addressの絶対参照を忘れないこと)
Dim strFormula As String: strFormula = "=B3=MAX(" & tRng.Address & ")"
Set fc = tRng.FormatConditions.Add( _
Type:=xlExpression, _
Formula1:=strFormula)
' 最大値の見た目を設定
fc.Interior.Color = RGB(255, 0, 0)
fc.Font.Color = RGB(255, 255, 255)
fc.Font.Bold = True
' グラフ生成用に、ヘッダーと値の配列を作成
Dim arr_ans_header As Variant: arr_ans_header = WorksheetFunction.Transpose(WorksheetFunction.Index(arr_ans, 1, 0))
Dim arr_ans_val As Variant: arr_ans_val = WorksheetFunction.Transpose(WorksheetFunction.Index(arr_ans, 2, 0))
' グラフを生成
Call MakeChart(Sheet1, arr_ans_header, arr_ans_val, line_val)
' *** 全体的な見た目の設定 ****
Call SetFormat(Sheet1, Sheet1.Range(Cells(2, 2), Cells(2, clm)), "id")
Call SetFormat(Sheet1, Sheet1.Range(Cells(3, 2), Cells(3, clm)), "val")
' フォーカスを所定の位置へ
Sheet1.Range("A1").Select
End Sub
' 書式を設定
' 項目:id 、値:val
Sub SetFormat(ByVal sh As Worksheet, ByVal rng As Range, ByVal item As String)
sh.Select
rng.Select
With Selection
' 外枠の設定・・・ちなみにこれは、中太
'.BorderAround Weight:=xlMedium
.Borders.LineStyle = True
Select Case item
Case "id"
.HorizontalAlignment = xlCenter
.Interior.Color = rgbTurquoise
Case "val"
.NumberFormatLocal = "#,###"
End Select
End With
End Sub
' グラフを生成
Sub MakeChart(ByVal sh As Worksheet, ByVal arr_header As Variant, ByVal arr_val As Variant, ByVal line_val As Long)
sh.Select
Dim co As ChartObject
' グラフの外枠?を設置
Set co = ActiveSheet.ChartObjects.Add(Left:=Range("G8").Left, Top:=Range("G8").Top, Width:=324, Height:=206)
' グラフの中身を生成
With co
With .Chart.SeriesCollection.NewSeries
.Name = "Value"
.Values = arr_val
.XValues = arr_header
End With
End With
With co.Chart
'グラフ形式を設定
co.Chart.ChartType = xlColumnClustered
'凡例非表示
co.Chart.HasLegend = True
' グラフの左線を強調(線の太さと色・・・結構見やすいかも)
.Axes(xlValue).Format.Line.Weight = 2
.Axes(xlValue).Format.Line.ForeColor.RGB = RGB(0, 0, 0)
' グラフの下線を強調
.Axes(xlCategory).Format.Line.Weight = 2
.Axes(xlCategory).Format.Line.ForeColor.RGB = RGB(0, 0, 0)
'基準線を新規系列として追加
With .SeriesCollection.NewSeries
.Name = "=""閾値""" '特に必要はない
.Values = "={" & Join(Array(line_val, line_val), ",") & "}"
.ChartType = xlLine '折れ線
.AxisGroup = 2 '第2軸
.Format.Line.ForeColor.RGB = vbRed 'RGB(255, 0, 0)
End With
'第2縦軸のScaleを第1縦軸に合わせる
.Axes(xlValue, 2).MinimumScale = .Axes(xlValue, 1).MinimumScale
.Axes(xlValue, 2).MaximumScale = .Axes(xlValue, 1).MaximumScale
.Axes(xlValue, 2).Delete '第2軸を消す
'グラフ内左右余白を消す:基準線を第2横軸に設定
.HasAxis(xlCategory, 2) = True '第2横軸表示
.Axes(xlCategory, 2).AxisBetweenCategories = False '軸位置を目盛
.Axes(xlCategory, 2).TickLabelPosition = xlNone '目盛ラベルなし
End With
End Sub