用于非相邻细胞选择的选择十字准线

Question

背景:我有一个大型的Excel工作表,我在其中创建了一个"十字准线",以便在与当前所选单元格相同的行和列中的数据之间轻松进行比较.我见过的大多数"十字准线"导航技巧使用格式化,这将删除或覆盖我现有的条件格式.我的解决方法是使用透明线突出显示当前所选单元格的行和列.

问题:代码适用于大多数选择集,但非相邻单元格选择除外.对于非相邻单元格,它仅突出显示选择中的第一个单元格.例如:如果我选择F10然后选择H6,我期待两个十字准线:一个以中心为中心F10,另一个以中心为中心H6.相反,有一个以十字形为中心的十字准线F10.

问题:有没有办法创建一个适用于非相邻单元格选择的选择十字准线？

现行代码:

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

    Dim On_Off As Boolean
    On_Off = True
    If On_Off = False Then Exit Sub

    Dim Sht As Worksheet
    Dim Rng As Range
    Set Sht = ActiveSheet
    Set Rng = Selection
    Dim Shp As Shape
    Dim Clr As Long
    Dim RWt As Double
    Dim CWt As Double
    Dim Trns As Double

    Clr = RGB(100, 20, 180)
    Trns = 0.85
    RWt = Rng.Height
    CWt = Rng.Width

    Debug.Print Rng.Address(False, False, xlA1)

    For Each Shp In Sht.Shapes
        If Shp.Name = "RowLine" Or Shp.Name = "ColLine" Then
            Shp.Delete
        End If
    Next Shp

    With Sht.Shapes.AddConnector(msoConnectorStraight, 0, _
        Rng.Top + Rng.Height / 2, 10000, Rng.Top + Rng.Height / 2)
        .Name = "RowLine"
        .Line.ForeColor.RGB = Clr
        .Line.Transparency = Trns
        .Line.Weight = RWt
    End With

    With Sht.Shapes.AddConnector(msoConnectorStraight, _
        Rng.Left + Rng.Width / 2, 0, Rng.Left + Rng.Width / 2, 10000)
        .Name = "ColLine"
        .Line.ForeColor.RGB = Clr
        .Line.Transparency = Trns
        .Line.Weight = CWt
    End With

End Sub

Answer 1

像这样的东西:

编辑:为最多3个不同的区域添加不同的颜色

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

    Dim On_Off As Boolean
    On_Off = True
    If On_Off = False Then Exit Sub

    Dim Sht As Worksheet
    Dim Rng As Range, a As Range, c As Range, i As Long
    Set Sht = ActiveSheet
    Set Rng = Selection
    Dim Shp As Shape
    Dim Clrs
    Dim RWt As Double
    Dim CWt As Double
    Dim Trns As Double

    Clrs = Array(vbRed, vbYellow, vbGreen)
    Trns = 0.85

    For Each Shp In Sht.Shapes
        If Shp.Name Like "RowLine*" Or Shp.Name Like "ColLine*" Then
            Shp.Delete
        End If
    Next Shp

    For Each a In Rng.Areas
        i = i + 1
        Debug.Print a.Address(False, False, xlA1)

        With Sht.Shapes.AddConnector(msoConnectorStraight, 0, _
            a.Top + a.Height / 2, 10000, a.Top + a.Height / 2)
            .Name = "RowLine" & i
            .Line.ForeColor.RGB = Clrs(i Mod 3)
            .Line.Transparency = Trns
            .Line.Weight = a.Height
        End With

        With Sht.Shapes.AddConnector(msoConnectorStraight, _
            a.Left + a.Width / 2, 0, a.Left + a.Width / 2, 10000)
            .Name = "ColLine" & i
            .Line.ForeColor.RGB = Clrs(i Mod 3)
            .Line.Transparency = Trns
            .Line.Weight = a.Width
        End With

    Next a

End Sub

Answer 2

该代码适用于大多数选择集，但不相邻的单元格选择除外。对于不相邻的单元格，它仅突出显示选择中的第一个单元格。例如：如果我选择 F10 然后选择 H6，我希望有两个十字准线：一个以 F10 为中心，另一个以 H6 为中心

当您必须选择non-adjacent同一行中的单元格时，您当前遵循的方法将不起作用，因为形状将通过叠加自身来阻挡单元格。

替代方法

这个逻辑可以用一个问题来最好地解释。

当您录制宏，然后选择会发生什么Col F，然后Row 10再Col H和Row 6？

这正是您选择F10然后H6使用Ctrl键选择时想要发生的情况。

如果您查看宏记录器创建的代码，您将看到

Range("F:F,10:10,H:H,6:6").Select

这就是整个逻辑的基础。

代码

我没有做任何错误处理。我相信你可以照顾它。

Option Explicit

Dim addr As String

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Dim aCell As Range, CompleteSelection As Range, LastCell As Range
    Dim sTemp As String
    Dim col As Long, rw As Long
    Dim MyAr

    '~~> Check if what the user selected is a valid range
    If TypeName(Selection) <> "Range" Then Exit Sub

    Set CompleteSelection = Nothing
    If Selection.Cells.Count = 1 Then addr = ""

    If InStr(1, Target.Address, ",") Then
        MyAr = Split(Target.Address, ",")
        sTemp = MyAr(UBound(MyAr))
        Set aCell = Range(sTemp)
    Else
        Set aCell = Target
    End If

    Set LastCell = aCell

    col = aCell.Column: rw = aCell.Row

    sTemp = Split(Cells(, col).Address, "$")(1) & ":" & _
               Split(Cells(, col).Address, "$")(1) & "," & _
               rw & ":" & rw

    If addr = "" Then
        addr = sTemp
    Else
        addr = addr & "," & sTemp
    End If

    Set CompleteSelection = Range(addr)

    Application.EnableEvents = False
    If Not CompleteSelection Is Nothing Then CompleteSelection.Select
    LastCell.Activate
    Application.EnableEvents = True
End Sub