Simplify range of offset values - excel

My script works in its entirety but there's one section of it I want to "tone" up and simplify. I have three values that I'm removing highlight from if one of the cells meets a certain condition. I apply the same WITH statement to all three cells. It'd be nice to trim it to select all three values so I can reduce it to only one loop.
I'm including only the important part of the script for simplicity so ignore the missing definitions.
For Each rngCell In NetworkPatchRange
If InStr(rngCell.Value, "-") > 0 Then
rngCell.Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
rngCell.Offset(0, -1).Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
rngCell.Offset(0, -2).Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
Next

Avoid using Select in Excel VBA macros.
For Each rngCell In NetworkPatchRange
If cbool(InStr(1, rngCell.Value, chr(45))) Then
rngCell.offset(0, -2).resize(1, 3).interior.Pattern = xlNone
End If
Next
The recorded macro code for removing a highlight performs more actions than is actually necessary. Just set the .interior.Pattern to xlNone.
It may be prudent to remember that manually removing a cell's 'Fill' (aka highlight) does not apply to cells that have been highlighted with a conditional formatting rule.

Related

Applying Conditional Formatting Row By Row based on Cell Critieria

Struggling with this one. Have a table with many columns but looking to apply the conditional formatting to a subset. Table looks like below. Number/name of columns are fixed but number of rows varies based on some user inputs. Below image shows the table
Table Image
With this table I am looking to apply the color scale conditional formatting on a row by row basis. The added wrinkle is the formatting needs to be dependent on the value in the column titled "Sign". Logic goes if Sign value in row is "+" then applies color scale with green for highest value, red for lowest and white for 50th percentile (used macro recorder to capture stock color scales in excel to produce code below). If Sign value in row is "-" then I reverse it with Red for highest value, green for lowest.
My code is as per below. Problem I'm facing is it is duplicating the formatting for each row MANY times and slowing down everything. Any ideas why its duplicating the formatting for each row?
Any help is GREATLY appreciated!
Dim Rng As Range
Dim cel As Range
Dim i As Integer
Application.ScreenUpdating = False
For Each Rng In Worksheets("Sheet1").Range("Table1[[Sign]:[TREND5]]").Rows
For Each cel In Rng.Cells
For i = 1 To Len(cel)
If cel.Value = "+" Then
Rng.FormatConditions.AddColorScale ColorScaleType:=3
Rng.FormatConditions(Rng.FormatConditions.Count).SetFirstPriority
Rng.FormatConditions(1).ColorScaleCriteria(1).Type = _
xlConditionValueLowestValue
With Rng.FormatConditions(1).ColorScaleCriteria(1).FormatColor
.Color = 7039480
.TintAndShade = 0
End With
Rng.FormatConditions(1).ColorScaleCriteria(2).Type = _
xlConditionValuePercentile
Rng.FormatConditions(1).ColorScaleCriteria(2).Value = 50
With Rng.FormatConditions(1).ColorScaleCriteria(2).FormatColor
.Color = 16776444
.TintAndShade = 0
End With
Rng.FormatConditions(1).ColorScaleCriteria(3).Type = _
xlConditionValueHighestValue
With Rng.FormatConditions(1).ColorScaleCriteria(3).FormatColor
.Color = 8109667
.TintAndShade = 0
End With
ElseIf cel.Value = "-" Then
Rng.FormatConditions.AddColorScale ColorScaleType:=3
Rng.FormatConditions(Rng.FormatConditions.Count).SetFirstPriority
Rng.FormatConditions(1).ColorScaleCriteria(1).Type = _
xlConditionValueLowestValue
With Rng.FormatConditions(1).ColorScaleCriteria(1).FormatColor
.Color = 8109667
.TintAndShade = 0
End With
Rng.FormatConditions(1).ColorScaleCriteria(2).Type = _
xlConditionValuePercentile
Rng.FormatConditions(1).ColorScaleCriteria(2).Value = 50
With Rng.FormatConditions(1).ColorScaleCriteria(2).FormatColor
.Color = 16776444
.TintAndShade = 0
End With
Rng.FormatConditions(1).ColorScaleCriteria(3).Type = _
xlConditionValueHighestValue
With Rng.FormatConditions(1).ColorScaleCriteria(3).FormatColor
.Color = 7039480
.TintAndShade = 0
End With
End If
Next i
Next
Next
Application.ScreenUpdating = True
End Sub

VBA - Add Cell Value to Total Sum if Checkbox is Checked

I'm not sure if the heading is accurately describing what my query is, so I'll try my best to describe it here.
I have a sheet that keeps track of expenses and income and I have a macro that I use to insert check boxes into selected cells, link the checkbox to those cells and finally, apply a condition for a conditional format once the checkbox is checked and likewise if it is unchecked again.
Here is code that does that:
Sub:
Sub Insert_Checkbox_Link_Cell()
Dim rngCel, myCells As Range
Dim ChkBx As CheckBox
Dim cBx As Long
Set myCells = Selection
myCells.NumberFormat = ";;;"
Application.ScreenUpdating = False
For Each rngCel In myCells
With rngCel.MergeArea.Cells
If .Resize(1, 1).Address = rngCel.Address Then
Set ChkBx = ActiveSheet.CheckBoxes.Add(.Left, .Top, .Width, .Height)
With ChkBx
.Value = xlOff
.LinkedCell = rngCel.MergeArea.Cells.Address
.Text = ""
.Width = 18
.Top = rngCel.Top + rngCel.Height / 2 - ChkBx.Height / 2
.Left = rngCel.Left + rngCel.Width / 2 - ChkBx.Width / 2
.Select
'Function Call
Selection.OnAction = "Change_Cell_Colour"
End With
End If
End With
Next rngCel
If (Range(ChkBx.LinkedCell) = "True") Then
myCells.Interior.ColorIndex = 43
Else
myCells.Interior.ColorIndex = 48
End If
Application.ScreenUpdating = True
End Sub
Function:
Function Change_Cell_Colour()
Dim xChk As CheckBox
Dim clickedCheckbox As String
clickedCheckbox = Application.Caller
Set xChk = ActiveSheet.CheckBoxes(clickedCheckbox)
If xChk.Value = 1 Then
ActiveSheet.Range(xChk.LinkedCell).Interior.ColorIndex = 43
Else
ActiveSheet.Range(xChk.LinkedCell).Interior.ColorIndex = 48
End If
End Function
So how this works is, I select the range of cells I want to have the checkboxes in, then I run the macro and it inserts the checkboxes as stated above.
Now I am wanting to add a little more and I am not sure if it is possible.
In the image below, I have listed income and at the bottom is the total. So, as the money comes in, the checkbox is checked.
What I would like to do is this:
While the checkbox is UNCHECKED, I don't want the value in the cell to be added to the total count at the bottom.
When it is CHECKED, then the value in the cell should be added to the total count at the bottom.
Image 1: No Check Boxes
Image 2: Check Boxes Added
Image 3: One Check Box Checked
Image 4: 2 Checkboxes Checked
You could achieve this using Conditional Formatting and SUMIF formula to achieve this
I've used the following conditional formatting rules (You will need to change this for your ranges)
The conditional formatting is applied to both the cell fill and also the font text colour (to make the True/False be 'invisible')
In cell C6 (a merged range) I have the formula
=SUMIF($D$3:$D$5,TRUE,$C$3:$C$5)
Where cells in the D range contain the values of the linked cells for the checkboxes (i.e. True, False)and C range is the values you want to sum.
This is a much simpler approach then any VBA solution and personally, I'd remove the formatting of the cells from your vba above and just use the conditional formatting.
If you're looking for a VBA way to initiate this (except for the SUMIF formula) I've updated your below code to add the conditional formatting
Sub Insert_Checkbox_Link_Cell()
Dim rngCel, myCells As Range
Dim ChkBx As CheckBox
Dim cBx As Long
Set myCells = Selection
myCells.NumberFormat = ";;;"
Application.ScreenUpdating = False
For Each rngCel In myCells
With rngCel.MergeArea.Cells
If .Resize(1, 1).Address = rngCel.Address Then
Set ChkBx = ActiveSheet.CheckBoxes.Add(.Left, .Top, .Width, .Height)
With ChkBx
.Value = xlOff
.LinkedCell = rngCel.MergeArea.Cells.Address
.Text = ""
.Width = 18
.Top = rngCel.Top + rngCel.Height / 2 - ChkBx.Height / 2
.Left = rngCel.Left + rngCel.Width / 2 - ChkBx.Width / 2
End With
End If
End With
Next rngCel
With myCells
' Set default value
.Value2 = False
' Add conditional formatting for False value
With .FormatConditions
.Add Type:=xlExpression, Formula1:="=" & myCells.Cells(1).Address(False, True) & "=False"
End With
With .FormatConditions(.FormatConditions.Count)
.SetFirstPriority
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 9868950
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With .Font
.Color = -6908266
.TintAndShade = 0
End With
End With
' Add conditional formatting for True value
With .FormatConditions
.Add Type:=xlExpression, Formula1:="=" & myCells.Cells(1).Address(False, True) & "=True"
End With
With .FormatConditions(.FormatConditions.Count)
.SetFirstPriority
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 52377
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With .Font
.Color = -16724839
.TintAndShade = 0
End With
End With
End With
Application.ScreenUpdating = True
End Sub
You can give a value (eg: 1 for checked and 0 for unchecked) to the cell where the checkbox is added in your color change function. keep the cell's font color the same as the cell's fill color so that the value will be invisible to naked eyes. then in the total sum section, you can use sumif function.

Need help looping macro

I don't believe this is very difficult but I can't figure it out...
In column B, I have either "Original" or "Add" listed. Starting from B79 and moving upwards, the first time "Original" is displayed I want to draw a border from B#:N# on the bottom.
I don't know how to run proper loops within VBA so below is what I have so far which is missing quite a bit.
Sub Test()
Range("B79").Select
If Range("B79") = "Original" Then
Selection.End(xlToRight).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlDot
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Else: ActiveCell.Offset(-1, 0).Select
End If
End Sub
Here is my current attempt. I am just trying to get it to highlight the cells.
Sub Test()
Let x = 79
Do While x > 7
If ("B" & x) = "Original" > 0 Then
Selection.End(xlToRight).Select
Else: x = x - 1
End If
Loop
End Sub
Use a for next loop and don't select, this should do what you need. Make sure you read this code and understand how it relates back to your original code.
Sub Test()
Dim X As Long
For X = 79 To 1 Step -1 'Step -1 makes it go backwards
If Range("B" & X).Text = "Original" Then 'Notice I am not actually selecting anything in this code, I don't need to in order to manipulate it
With Range("B" & X).End(xlToRight)
For Each Border In .Borders 'Loop the borders so you don't have to name each one
Border.LineStyle = xlNone
Next
With .Borders(xlEdgeTop)
.LineStyle = xlDot
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
End With
End If
Next
End Sub

Code for automatic marked headings

How can I get headings "underproject" to be darker marked automatic? I can do it myself, but want it to happen automatic for all headings.
Before & After
Range("A6:L6,A7:D7").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0.249977111117893
.PatternTintAndShade = 0
End With
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
You can do this with conditional formatting. Select the whole table column A to column G and add a new conditional formmating rule and choose the bottom option to enter a formula. enter =left($A1,4)="Unde" click the format button and choose the format you want.
Select the Columns A to C and create another conditional formatting rule and select formula. Enter =left($A1,4)="Navn" and set the format that you want.
this won't merge the cells but in my opinion it is better no keep the cells unmerged as it allows you to sort and filter the data if required.
It is possible using a Macro but you would have to loop through all the cells in column A looking for "Navn" and "Underproject" and use if statements to set the formats.
Code to delete rows based on heading
I can't tell from your comment what it is exactly that you want to delete but to can change the critera to suit your requirements.
IMPORTANT: make sure that you make a backup copy of your data before running this macro as changes made by the macro cannot be undone.
Sub DeleteEx()
Dim intRow As Integer
Dim strContinue As String
Dim bolDelete As Boolean 'true or false
intRow = 2
strContinue = Cells(intRow, 1) ' the value in A2
bolDelete = False
Do While strContinue <> "" ' this loop will continue down each row as long as there is a value in column A
If Left(strContinue, 5) = "Under" Or Left(strContinue, 5) = "Navn:" Then 'change this to match your criteria
'delete the current row
Rows(intRow & ":" & intRow).Delete Shift:=xlUp
intRow = intRow - 1 ' because we deleted a row
End If
intRow = intRow + 1
strContinue = Cells(intRow, 1)
Loop
End Sub

excel vba subroutine call fails

I have the following problem. I want to call a soubroutine for changing the background color for a cell range. The cell range is calculated with cells(1,1) and then the address is calculated to receive A1.
Before the subroutine is called I get the addresses for my cells like this:
Range1 = cells(4, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False)
Range2 = cells(4, CellAmount - 1).Address(RowAbsolute:=False, ColumnAbsolute:=False)
I thought I need this because the subroutine is declared like this:
Sub SetBGLightGrey(cells As String)
range(cells).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 15921906
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End Sub
Range 1 and Range 2 are strings and I concat it to a range declaration:
RangeArea = """" & Range1 & ":" & Range2 & """"
When I call my subroutine like this:
Call SetBGLightGrey(RangeArea)
I get the following error-message:
"Run-time error '1004': Method 'Range' of object '_Global' failed. I don't understand it because if I call the subroutine with the correct cell values:
Call SetBGLightGrey("D4:K4")
it works. It is string and of the same value. This simply cannot be can it?
You do not need quotes around RangeArea.
RangeArea = Range1 & ":" & Range2
But then, why would you want to pass ranges around as strings and then convert them back to ranges? Pass the range objects all the time.
Sub SetBGLightGrey(byval cells as range)
With cells.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 15921906
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End Sub
SetBGLightGrey range(cells(4, 4), cells(4, CellAmount - 1))

Resources