非相邻小区select的select十字准线

背景：我有一个大的Excel工作表，我在其中创build了一个“十字准线”，以便于在当前选定的单元格的同一行和列中的数据之间进行比较。 大多数“十字线”导航技巧，我看到使用格式 ，这将删除或覆盖我现有的条件格式。 我的解决方法是使用透明线突出显示当前所选单元格的行和列。

问题：代码适用于大多数select集，除了非相邻的单元格select。 对于不相邻的单元格，只会突出显示select中的第一个单元格。 例如：如果我selectF10然后selectH6 ，我期望两个十字准线：一个以F10为中心，另一个以H6为中心。 相反，在F10处有一个单一的十字线。

问题：是否有创buildselect十字准线的方法可用于不相邻的单元格select？

当前代码：

 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

该代码适用于大多数select集，除了非相邻的单元格select。 对于不相邻的单元格，只会突出显示select中的第一个单元格。 例如：如果我selectF10，然后selectH6，我期望两个十字准线：一个以F10为中心，另一个以H6为中心

当你不得不在同一行中selectnon-adjacent单元格时，你当前所遵循的方法将不起作用，因为形状将通过叠加来阻止单元格。

替代方法

逻辑可以用一个问题来解释。

当您录制一个macros时，会发生什么情况，然后selectCol F ，然后selectRow 10 ，然后selectCol H和Row 6 ？

这正是您selectF10时想要发生的情况，然后使用Ctrl键selectH6 。

如果你看看macroslogging器创build的代码，你会看到

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

这就是整个逻辑的基础。

码

我没有做任何error handling。 我相信你可以照顾它。

 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