绘制六边形框

绘制六边形框

根据KPI数据，绘制六边形框，并显示KPI得分，颜色标注

'设置两个控件：执行，恢复
'UP/DOWN:控制颜色
    '行\高，列宽需要事先预设
    '添加六边形:大小，位置
    '添加数字:大小，位置
    '修改颜色:绿色|橙色

'****************************************************************************
'By Ted.Zheng, Elanco, 2020.01.14
'根据KPI数据，绘制六边形框，并显示KPI得分，颜色标注
'
'设置两个控件：执行，恢复
'UP/DOWN:控制颜色
    '行\高，列宽需要事先预设
    '添加六边形:大小，位置
    '添加数字:大小，位置
    '修改颜色:绿色|橙色
'****************************************************************************
Const ROW_Initial_Height = 13
Const COL_Initial_Width = 6
Const ROW_Shape_Height = 15
Const COL_Shape_Width = 15
Const COL_KPI_START = 8                 'Fill COLUMN
Const Shape_Width = 90
Const Shape_Height = 70
Const Shape_Margin = 5
'----------------------------------------------------------------------------
Sub Draw_Shapes()
Dim arr, i As Integer
Dim kpi_Name As String, kpi_Direct As String
Dim kpi_Target As Double, kpi_Base As Double, kpi_Actual As Double
Dim kpi_COL As Integer
Dim kpi_Color As Variant
Dim nTop As Single, nLeft As Single

Call Undo_All
arr = Range("A1").CurrentRegion
If IsEmpty(arr) Then Exit Sub
If UBound(arr) < 2 Then Exit Sub
'设置行高
For i = 2 To UBound(arr)
    '检查行高
    If Rows(i).RowHeight <> ROW_Shape_Height Then
        Rows(i).RowHeight = ROW_Shape_Height
    End If
Next i

For i = 2 To UBound(arr)
    '获取数据
    kpi_Name = arr(i, 2)
    kpi_Direct = arr(i, 3)
    kpi_Target = arr(i, 4)
    kpi_Base = arr(i, 5)
    kpi_Actual = arr(i, 6)
    '计算填充列
    kpi_COL = COL_KPI_START + i - 2
    '修改列宽
    Columns(kpi_COL).ColumnWidth = COL_Shape_Width
    '填充KPI名称
    Cells(1, kpi_COL) = kpi_Name
    '****************错误处理***************************************
    If Not (kpi_Direct = "UP" Or kpi_Direct = "DOWN") Then
        MsgBox ("UP/DOWN NEED BE SELECT")
        Exit Sub
    End If
    '***************************************************************
    '获取颜色标识
    kpi_Color = Identify_KPI_Color(kpi_Direct, kpi_Target, kpi_Base, kpi_Actual)
    '计算图形位置
    nLeft = Cells(3, kpi_COL).Left + Shape_Margin
    nTop = Cells(3, kpi_COL).Top
    '绘制图形
    With Shapes.AddShape(msoShapeHexagon, nLeft, nTop, Shape_Width, Shape_Height)
        '填充颜色
        .Fill.ForeColor.RGB = RGB(kpi_Color(0), kpi_Color(1), kpi_Color(2))
        '不显示边框
        .Line.Visible = msoFalse
        '填充值
        With .TextFrame
            .Characters.Text = kpi_Actual
            '文本字体
            .Characters.Font.Size = 30
            '文本居中
            .HorizontalAlignment = xlHAlignCenter
            .VerticalAlignment = xlVAlignCenter
        End With
        '设置图形名称
        .Name = i
    End With
Next i
Debug.Print Date, Time
Erase arr
End Sub

'--------------------------------------------------------------------------
'根据KPI的方向和值判断填充颜色
'http://dmcritchie.mvps.org/excel/colors.htm
Function Identify_KPI_Color(ByVal kpi_D As String, ByVal kpi_T, ByVal kpi_B, ByVal kpi_A)
Dim returnColor As Variant
Color_Good = Array(50, 153, 50)    'GREEN
Color_Close = Array(255, 153, 0)  'ORANGE
Color_Above = Array(200, 0, 0)   'RED
'获取颜色,UP:Actual>Target表示有利
        'DOWN:Actual<Target表示有利
If kpi_D = "UP" Then
    'KPI>T有利
    If kpi_A >= kpi_T Then
        If kpi_A >= kpi_B Then
            returnColor = Color_Good
        Else
            returnColor = Color_Close
        End If
    'KPI<T不利
    Else
        returnColor = Color_Above
    End If
ElseIf kpi_D = "DOWN" Then
    'KPI<T有利
    If kpi_A <= kpi_T Then
        If kpi_A < kpi_B Then
            returnColor = Color_Good
        Else
            returnColor = Color_Close
        End If
    'KPI>T不利
    Else
        returnColor = Color_Above
    End If
End If
'返回颜色值
Identify_KPI_Color = returnColor
End Function

'----------------------------------------------------------------------------
'移除所有图形框
Sub Undo_All()
Dim m As Integer
Dim shp As Shape
With Cells
    '初始化行高
    .EntireRow.RowHeight = ROW_Initial_Height
    '初始化列宽
    .EntireColumn.ColumnWidth = COL_Initial_Width
    '清除颜色
    .Interior.ColorIndex = 0
    '清除数据区域
    .Cells(1, COL_KPI_START).CurrentRegion.ClearContents
End With
'清除图片
For Each shp In Shapes
    If shp.Type <> msoFormControl Then shp.Delete
Next
End Sub

'==============================================================================
'FILL IN COLUMN 'C' DATA.VALIDATION
'==============================================================================
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim v_list As String
Dim iMaxRow As Long
iMaxRow = Cells(65536, 1).End(xlUp).Row

If Target.Row < 2 Then Exit Sub
If Target.Row > iMaxRow Then Exit Sub
If Target.Column <> 3 Then Exit Sub
If Target.Count > 2 Then Exit Sub

'数据有效性清单
v_list = "UP,DOWN"
With Target.Validation
    .Delete
    .Add 3, 1, 1, v_list
End With

End Sub
'=============================================================================

 

来源：oschina

链接：https://my.oschina.net/tedzheng/blog/3158840