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)?
5 Answers
Answers 1
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 :
Answers 2
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.
Answers 3
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 If CrossDisabled Then DeleteCross ws Else DeleteCross ActiveSheet CreateCross ActiveCell End If 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 Answers 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 Answers 5
Would you consider using some add-in like rowliner?
0 comments:
Post a Comment