Selection Crosshair for Non-Adjacent Cell Selection

Question

Background: I have a large Excel worksheet in which I created a "crosshair" for easy comparisons between data in the same row and column as the currently selected cell. Most "crosshair" navigation tricks I have seen use formatting, which would either delete or overwrite my existing conditional formatting. My work-around was to use a transparent line to highlight the row and column of the currently selected cell.

Problem: The code works for most selection sets, except for non-adjacent cell selections. For non-adjacent cells, it only highlights the first cell in the selection. Ex: If I select F10 then select H6, I expect two crosshairs: one centered at F10, and another centered at H6. Instead, there is a single crosshair centered at F10.

Question: Is there a way to create a selection crosshair which will work for non-adjacent cell selections?

Current Code:

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

Something like this:

EDIT: added different colors for up to 3 distinct areas

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

The code works for most selection sets, except for non-adjacent cell selections. For non-adjacent cells, it only highlights the first cell in the selection. Ex: If I select F10 then select H6, I expect two crosshairs: one centered at F10, and another centered at H6

The approach you are currently following will not work when you have to select the non-adjacent cell in the same row as the shape will block the cell by superimposing itself.

Alternative Approach

The logic can be best explained by a question.

What happens when you record a macro and then select Col F and then Row 10 and then Col H and Row 6?

This is exactly what you want to happen when you select F10 and then select H6 using the Ctrl key.

If you look at the code the macro recorder created, you will see

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

And this is where the entire logic is based on.

Code

I have not done any error handling. I am sure you can take care of it.

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