Easy navigation in excel within the same row with the aid of a hairline cross

问题

I have a Excel file (xls) with 20 sheets and like to navigate easily on the same row with the aid of a semi-transparent grey hairline cross. I'm a newbie in VBA and I've spend several hours searching a solution, unfortunately without success at now.

Let's say in B3 there is the number 7 written, in B4 the number 10:

a) if I click on an arbitrary cell, e.g. B3, I'd like to have a hairline cross over column B and row 3

b) if I mark with the mouse the fields B3 and B4, the hairline cross (initially at B3) should disappear, next when I go with the mouse coursor to the bottom right of the cell B4 and drag the "plus"-sign into the next cell B5 Excel automatically should paste the number 13 (difference of 3 added to number 10) in cell B5. The "formula-drag-and-drop" function should also work with formulas. (With most Excel files /Add-Ins I've tried unfortunately this wasn't possible).

Does someone knows an easy and workable solution for aims a) and b)?

EDIT: Usability of other excel functions (e.g. undo and redo) should remain.

回答1:

I've assembled a piece of VBA that should match your requirements. Just past the code in ThisWorkbook, it will activate the hairline cross in all the sheets. FYI, the hairline cross is created with a conditional format on the current row/column and updated when the selection changes.

Code to place in ThisWorkbook :

Private Const CROSS_BACKGROUND_COLOR = &HE0E0EA
Private Const CROSS_BORDER_COLOR = &HE0E0E0
Private Const CROSS_PATTERN = xlPatternGray50
Private Const CELL_BACKGROUND_COLOR = &HFFFFFF

Private Sub Workbook_SheetSelectionChange(ByVal sh As Object, ByVal target As Range)
  Dim cdt As FormatCondition, cdtCross As FormatCondition, cdtCell As FormatCondition

  ' get the conditional formats for the sheet
  For Each cdt In Cells.FormatConditions
    If cdt.type = xlExpression Then
      If cdt.Formula1 = "=-1" Then
        Set cdtCell = cdt
      ElseIf cdt.Formula1 = "=-2" Then
        Set cdtCross = cdt
      End If
    End If
  Next

  ' diplay the cross if one cell is selected and if a copy/paste is not occuring
  If target.Columns.count = 1 And target.Rows.count = 1 And Application.CutCopyMode = 0 Then
    If cdtCell Is Nothing Then
      ' create the cross with a format condition on the row and column
      With target.FormatConditions.Add(xlExpression, Formula1:="=-1")
        .Interior.Color = CELL_BACKGROUND_COLOR
      End With
      With Union(target.EntireRow, target.EntireColumn) _
           .FormatConditions.Add(xlExpression, Formula1:="=-2")
        .Interior.PatternColor = CROSS_BACKGROUND_COLOR
        .Interior.pattern = CROSS_PATTERN
        .Borders.Color = CROSS_BORDER_COLOR
      End With
    Else
      ' update the position of the cross
      cdtCell.ModifyAppliesToRange target
      cdtCross.ModifyAppliesToRange Union(target.EntireRow, target.EntireColumn)
    End If
  ElseIf Not cdtCell Is Nothing Then
    ' hide the cross at the bottom if the selection has more than one cell
    If cdtCross.AppliesTo.Column - cdtCell.AppliesTo.Column <> 1 Then
      cdtCell.ModifyAppliesToRange Cells(sh.Rows.count, 1)
      cdtCross.ModifyAppliesToRange Cells(sh.Rows.count, 2)
    End If
  End If
End Sub

Another solution less prone to issues would be to delete the format conditions for each section change. However it might be less performant.

EDIT2 : Added another version with support for a shortcut (Ctrl+Shif+8):

''
' Code to place in ThisWorkbook
''

Private Sub Workbook_Open()
  Application.OnKey "^+8", "ToggleCrossVisibility"
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal sh As Object, ByVal target As Range)
  DeleteCross sh
  If target.Columns.count = 1 And target.Rows.count = 1 Then CreateCross target
End Sub

''
' Code to place in a new Module
''

Private Const CROSS_BACKGROUND_COLOR = &HD0D0DA
Private Const CROSS_BORDER_COLOR = &HE0E0E0
Private Const CROSS_PATTERN = xlPatternGray50
Private Const CELL_BACKGROUND_COLOR = &HFFFFFF

Private CrossDisabled As Boolean

Private Sub ToggleCrossVisibility()
  CrossDisabled = CrossDisabled Xor True
  DeleteCross ActiveSheet
  If Not CrossDisabled Then CreateCross ActiveCell
End Sub

Public Sub DeleteCross(ByVal target As Worksheet)
  ' delete the cross by deleting the conditions
  Static conditions(0 To 10) As FormatCondition
  Dim condition As FormatCondition, i&
  For Each condition In target.Cells.FormatConditions
    If condition.type = xlExpression Then
      If condition.Formula1 = "=-1" Then
        Set conditions(i) = condition
        i = i + 1
      End If
    End If
  Next
  For i = 0 To i - 1
    conditions(i).Delete
  Next
End Sub

Public Sub CreateCross(ByVal target As Range)
  If CrossDisabled Then Exit Sub

  ' create the cross with a format condition on the row and column
  With target.FormatConditions.Add(xlExpression, Formula1:="=-1")
    .Interior.color = CELL_BACKGROUND_COLOR
  End With
  With Union(target.EntireRow, target.EntireColumn) _
       .FormatConditions.Add(xlExpression, Formula1:="=-1")
    .Interior.PatternColor = CROSS_BACKGROUND_COLOR
    .Interior.pattern = CROSS_PATTERN
    .Borders.color = CROSS_BORDER_COLOR
  End With
End Sub

回答2:

I will answer part (a), for part (b) since my solution to part (a) is not invasive to any cell's content, it will not affect your drag & drop, copy & paste and etc.

1. Create a blank worksheet and name it "CTRL"

2. Open VBA editor (Alt+F11) and paste this code to ThisWorkbook module

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    If Sh.Name <> "CTRL" Then
        ThisWorkbook.Worksheets("CTRL").Range("A1") = Target(1).Address
    End If
End Sub

3. Create two name formula

Click the Name Manager button and then click New.

First name formula is as follow:

Second name formula is as follow:

4. Create a conditional formatting using a formula to determine which cells to format

This, unfortunately, you need to create for each and every sheet.

The formatting rule is as follow:

This is the formula:

=OR(COLUMN(INDIRECT(ThisCellAddress))=COLUMN(INDIRECT(CrossAddress)),ROW(INDIRECT(ThisCellAddress))=ROW(INDIRECT(CrossAddress)))

The cell format you can choose 10% grey fill and white border on all sides.

And apply the rule to the entire worksheet, i.e. Applies to =$1:$1048576.

The outcome :

回答3:

Assuming you want this Cross Hair Highlight (CHH) for all your 20 sheets and each sheet retains the cross hair, you will need to place codes in each Worksheet object, and a Normal Module.

The CHH will be applied on the column and row of selected cell except itself. When more than 1 cells are selected, the CHH will be removed.

Codes for each Worksheet Object that features CHH:

Option Explicit

Private oPrevRange As Range

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    RangeSelectionChange Target, oPrevRange
End Sub

Create a new Module, say "CrossHair" and place below code (revised to add borders on cells):

Option Explicit

Private Const lColorCross As Long = 14277081 ' White with 15% darker: RGB(217,217,217)

Sub RangeSelectionChange(ByRef Target As Range, ByRef oPrevRange As Range)
    On Error Resume Next
    With Target
        If .Count = 1 Then
            If Not oPrevRange Is Nothing Then
                ' Undo highlight on previous range
                If .Row <> oPrevRange.Row Then UndoCrossHairRow oPrevRange
                If .Column <> oPrevRange.Column Then UndoCrossHairCol oPrevRange
            End If
            Set oPrevRange = Target
            MakeCrossHair Target
        Else
            UndoCrossHair oPrevRange
        End If
    End With
End Sub

Private Sub MakeCrossHair(ByRef oRng As Range)
    With oRng
        With .EntireRow
            .Interior.Color = lColorCross
            With .Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .ThemeColor = 1
                .TintAndShade = 0
                .Weight = xlThin
            End With
        End With
        With .EntireColumn
            .Interior.Color = lColorCross
            With .Borders(xlInsideHorizontal)
                .LineStyle = xlContinuous
                .ThemeColor = 1
                .TintAndShade = 0
                .Weight = xlThin
            End With
        End With
        .Interior.Pattern = xlNone
    End With
End Sub

Private Sub UndoCrossHair(ByRef oRng As Range)
    UndoCrossHairRow oRng
    UndoCrossHairCol oRng
End Sub

Private Sub UndoCrossHairRow(ByRef oRng As Range)
    oRng.EntireRow.Interior.Pattern = xlNone
    oRng.EntireRow.Borders(xlInsideVertical).LineStyle = xlNone
End Sub

Private Sub UndoCrossHairCol(ByRef oRng As Range)
    oRng.EntireColumn.Interior.Pattern = xlNone
    oRng.EntireColumn.Borders(xlInsideHorizontal).LineStyle = xlNone
End Sub

These interactions does not interfere normal Excel features, so second part of (b) is not an issue.

The only issue is if your data is already formatted nicely, this CHH with ruin it.

Sample screenshots:
Note some range (non Table ranges) has yellow filled background which got removed by CHH. It will be very hard to allow restoring them.

回答4:

put this in ThisWorkbook module

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

With Target
    If .Count = 1 Then
        Sh.Cells.Interior.ColorIndex = xlNone
        With ActiveCell
            .EntireRow.Interior.Color = RGB(217, 217, 217)
            .EntireColumn.Interior.Color = RGB(217, 217, 217)
        End With            
    Else
            Sh.Cells.Interior.ColorIndex = xlNone
            If .Count = 3 And .Columns.Count = 1 Then .Cells(3, 1) = 10 + (.Cells(2, 1) - .Cells(1, 1))
    End If        
End With

End Sub

回答5:

Would you consider using some add-in like rowliner?

来源：https://stackoverflow.com/questions/35817040/easy-navigation-in-excel-within-the-same-row-with-the-aid-of-a-hairline-cross