vba:課題

  • 新規ブックのsheet1に張り付ける
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