借助细线交叉，在同一行内轻松导航 excel
Easy navigation in excel within the same row with the aid of a hairline cross
我有一个包含 20 张纸的 Excel 文件 (xls)，我喜欢借助半透明的灰色细线十字在同一行上轻松导航。我是 VBA 的新手，我花了几个小时寻找解决方案，不幸的是现在没有成功。
假设 B3 中写的是数字 7，B4 中写的是数字 10：
a) 如果我点击任意单元格，例如B3，我想要细线穿过 B 列和第 3 行
b) 如果我用鼠标标记字段 B3 和 B4，细线交叉（最初在 B3）应该消失，接下来当我用鼠标光标移动到单元格 B4 的右下角并拖动 "plus"-登录到下一个单元格 B5 Excel 自动将数字 13（与数字 10 相差 3）粘贴到单元格 B5 中。 "formula-drag-and-drop" 函数也应该适用于公式。
（不幸的是，对于大多数 Excel 文件/加载项，这是不可能的）。
有人知道目标 a) 和 b) 的简单可行的解决方案吗？
编辑： 其他 excel 功能（例如撤消和重做）的可用性应该保留。
我会回答(a)部分，(b)部分因为我对(a)部分的解决方案不会侵入任何单元格的内容，它不会影响你的拖放、复制和粘贴等
1.创建一个空白作品sheet并命名为“CTRL”
2。打开 VBA 编辑器 (Alt+F11) 并将此代码粘贴到 ThisWorkbook 模块
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。创建两个名字公式
单击“名称管理器”按钮，然后单击“新建”。
名字公式如下：
第二名公式如下：
4.使用公式创建条件格式以确定要设置格式的单元格
不幸的是，您需要为每个 sheet 创建一个。
格式规则如下：
这是公式：
=OR(COLUMN(INDIRECT(ThisCellAddress))=COLUMN(INDIRECT(CrossAddress)),ROW(INDIRECT(ThisCellAddress))=ROW(INDIRECT(CrossAddress)))
您可以选择 10% 灰色填充和四面白色边框的单元格格式。
并将规则应用于整个作品sheet，即应用于=:48576。
The outcome :
假设您希望所有 20 sheet 都使用此十字准线突出显示 (CHH)，并且每个 sheet 保留十字准线，您将需要在每个作品中放置代码sheet 对象，和一个普通模块。
CHH 将应用于所选单元格的列和行，但它本身除外。 When more than 1 cells are selected, the CHH will be removed.
每个作品的代码sheet 具有 CHH 的对象：
Option Explicit
Private oPrevRange As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
RangeSelectionChange Target, oPrevRange
End Sub
创建一个新模块，说“CrossHair”并放置在代码下方（修改为在单元格上添加边框）：
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
这些交互不会干扰正常的 Excel 功能，因此 (b) 的第二部分不是问题。
唯一的问题是如果你的数据已经格式化好了，这个 CHH 会毁了它。
示例屏幕截图：
请注意某些范围（非 Table 范围）具有黄色填充背景，已被 CHH 删除。恢复它们将非常困难。
我整理了一份 VBA 应该符合您的要求。
只需通过 ThisWorkbook 中的代码，它将激活所有工作表中的细线交叉。
仅供参考，细线交叉是在当前 row/column 上使用条件格式创建的，并在选择更改时更新。
要放在 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
另一个不太容易出现问题的解决方案是删除每个部分更改的格式条件。但是它的性能可能较低。
EDIT2 : 添加了另一个支持快捷键 (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
将其放入 ThisWorkbook 模块
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
你会考虑使用一些插件吗
rowliner?
我有一个包含 20 张纸的 Excel 文件 (xls)，我喜欢借助半透明的灰色细线十字在同一行上轻松导航。我是 VBA 的新手，我花了几个小时寻找解决方案，不幸的是现在没有成功。
假设 B3 中写的是数字 7，B4 中写的是数字 10：
a) 如果我点击任意单元格，例如B3，我想要细线穿过 B 列和第 3 行
b) 如果我用鼠标标记字段 B3 和 B4，细线交叉（最初在 B3）应该消失，接下来当我用鼠标光标移动到单元格 B4 的右下角并拖动 "plus"-登录到下一个单元格 B5 Excel 自动将数字 13（与数字 10 相差 3）粘贴到单元格 B5 中。 "formula-drag-and-drop" 函数也应该适用于公式。 （不幸的是，对于大多数 Excel 文件/加载项，这是不可能的）。
有人知道目标 a) 和 b) 的简单可行的解决方案吗？
编辑： 其他 excel 功能（例如撤消和重做）的可用性应该保留。
我会回答(a)部分，(b)部分因为我对(a)部分的解决方案不会侵入任何单元格的内容，它不会影响你的拖放、复制和粘贴等
1.创建一个空白作品sheet并命名为“CTRL”
2。打开 VBA 编辑器 (Alt+F11) 并将此代码粘贴到 ThisWorkbook 模块
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。创建两个名字公式
单击“名称管理器”按钮，然后单击“新建”。
名字公式如下：
第二名公式如下：
4.使用公式创建条件格式以确定要设置格式的单元格
不幸的是，您需要为每个 sheet 创建一个。
格式规则如下：
这是公式：
=OR(COLUMN(INDIRECT(ThisCellAddress))=COLUMN(INDIRECT(CrossAddress)),ROW(INDIRECT(ThisCellAddress))=ROW(INDIRECT(CrossAddress)))
您可以选择 10% 灰色填充和四面白色边框的单元格格式。
并将规则应用于整个作品sheet，即应用于=:48576。
The outcome :
假设您希望所有 20 sheet 都使用此十字准线突出显示 (CHH)，并且每个 sheet 保留十字准线，您将需要在每个作品中放置代码sheet 对象，和一个普通模块。
CHH 将应用于所选单元格的列和行，但它本身除外。 When more than 1 cells are selected, the CHH will be removed.
每个作品的代码sheet 具有 CHH 的对象：
Option Explicit
Private oPrevRange As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
RangeSelectionChange Target, oPrevRange
End Sub
创建一个新模块，说“CrossHair”并放置在代码下方（修改为在单元格上添加边框）：
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
这些交互不会干扰正常的 Excel 功能，因此 (b) 的第二部分不是问题。
唯一的问题是如果你的数据已经格式化好了，这个 CHH 会毁了它。
示例屏幕截图：
请注意某些范围（非 Table 范围）具有黄色填充背景，已被 CHH 删除。恢复它们将非常困难。
我整理了一份 VBA 应该符合您的要求。 只需通过 ThisWorkbook 中的代码，它将激活所有工作表中的细线交叉。 仅供参考，细线交叉是在当前 row/column 上使用条件格式创建的，并在选择更改时更新。
要放在 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
另一个不太容易出现问题的解决方案是删除每个部分更改的格式条件。但是它的性能可能较低。
EDIT2 : 添加了另一个支持快捷键 (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
将其放入 ThisWorkbook 模块
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
你会考虑使用一些插件吗 rowliner?