excel 自制指示器

自贡黄明儒

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
   Call MsoLineRun(Sh, Target)
End Sub

'''增加一个虚箭头
Function AddMsoLine(ByVal s As String, ByVal Sh As Object) As Object
    Set AddMsoLine = Sh.Shapes.AddConnector(msoConnectorStraight, 0, 0, 100, 50)
    With AddMsoLine.Line
        .EndArrowheadStyle = msoArrowheadOpen
        .Visible = msoTrue
        .DashStyle = msoLineDashDot
        .ForeColor.RGB = RGB(255, 0, 0)
        .Weight = 0
        .Parent.AlternativeText = s
        .Parent.Name = s
    End With
End Function
''判断虚箭头是否存在，不存在则添加
Function MsoLineExist(ByVal s As String, ByVal Sh As Object) As Object
    For Each X In Sh.Shapes
        If X.Name = s And X.AlternativeText = s Then Set MsoLineExist = X: Exit For
    Next
End Function

'''小平箭头Hor1,竖直箭头Ver1
Sub MsoLineRun(ByVal Sh As Object, ByVal Target As Range)
    Dim obj As Object
    Dim Left1&, Top1&, Column1&, Row1&
    Application.ScreenUpdating = False
    Application.EnableEvents = False
   
    If Target.Rows.Count = 1 And Target.Columns.Count = 1 Then
    Application.ScreenUpdating = False
    Application.ScreenUpdating = True
        With ActiveCell
            Left1 = .Left
            Top1 = .Top
            Column1 = .Column
            Row1 = .Row
        End With
        Set obj = MsoLineExist("Hor1", Sh)
        If obj Is Nothing Then Set obj = AddMsoLine("Hor1", Sh)
        With obj
            .Left = Left1 + ActiveCell.Width * 0.5
            .Top = Sh.Cells(1, Column1).Top
            .Width = 0
            .Height = Top1
        End With
        Set obj = MsoLineExist("Ver1", Sh)
        If obj Is Nothing Then Set obj = AddMsoLine("Ver1", Sh)
        With obj
            .Left = Sh.Cells(Row1, 1).Left
            .Top = Top1 + ActiveCell.Height * 0.25
            .Width = Left1
            .Height = 0
        End With
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
'''箭头删除
Sub KillMsoLine()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    For Each X In ActiveSheet.Shapes
        If X.Type = msoAutoShape Then
            If InStr(X.Name, "Hor") > 0 Or InStr(X.Name, "Ver") > 0 Then X.Delete
        End If
    Next
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

自贡黄明儒

以上是完整代码，贴入excel就可运行。

逍遥君风

谢谢楼主分享。

yudi17

谢谢楼主分享

youlong0215

谢谢楼主分享。

cayuer

楼主已经把表格玩转了

zhang631202

楼主：
   你不发个怎样加载，我们才会用呢。

joyb

自贡黄明儒 发表于 2022-7-7 09:36
以上是完整代码，贴入excel就可运行。

怎么贴，试了粘贴不能用

自贡黄明儒

joyb 发表于 2022-7-12 17:03
怎么贴，试了粘贴不能用

只能帮你到这一步了