I'm working on a macro that highlighted & colors the empty cells in a specific column (AE), but I need to clear this color-highlighted based on a result that exists in the column (AD)
If AD column, cells value = "SPLICE" clear color, If Empty the color should exist, below picture explains more.
I use the code below
Sub EmptyTerminalTO()
Application.ScreenUpdating = False
Sheets("Wire List").Activate
Dim i As Long
Dim c As Long
Dim myRange As Range
Dim myCell As Range
Set myRange = Range("AD2", Range("AD" & Rows.Count).End(xlUp))
For Each myCell In myRange '
c = c + 1
If (myCell) = "" Then
myCell.Interior.Color = RGB(255, 87, 87)
i = i + 1
End If
Next myCell
Rapport8 = i
Application.ScreenUpdating = True
End Sub
try using offset as per code below:
Option Explicit
Sub EmptyTerminalTO()
Application.ScreenUpdating = False
Sheets("Wire List").Activate
Dim i As Long
Dim c As Long, Rapport8 As Long
Dim myRange As Range
Dim myCell As Range
Set myRange = Range("AD2", Range("AD" & Rows.Count).End(xlUp))
For Each myCell In myRange '
c = c + 1
If myCell <> "SPLICE" & myCell.Offset(0, 1)="" Then
myCell.Offset(0, 1).Interior.Color = RGB(255, 87, 87)
Else
myCell.Offset(0, 1).Interior.Pattern = xlNone
i = i + 1
End If
Next myCell
Rapport8 = i
End Sub
Related
I am trying to loop over a column L in my sheet and then color the cell red if value is not in “big box” and “small box”. The problem is I cannot figure out what I am doing wrong, and VBA is not throwing any errors now.
Sub data_validation_from_array()
Dim packages As Variant
Dim packages_range As Range
Dim cell_value As String
Dim vFilter
Set active_sheet = ActiveSheet
last_row = active_sheet.Range("L" & active_sheet.Rows.Count).End(xlUp).row
Set rng = active_sheet.Range("L2" & last_row)
packages = Array("big box", "small box")
For Each cel In rng
cell_value = cel.Value
vFilter = Filter(packages, cell_value, True)
If Not cell_value = vFilter(i) Then
cel.Interior.Color = vbRed
End If
Next cel
End Sub
Sub data_validation_from_array()
Dim packages_range As Range
Dim cell As Range
Dim last_row As Long
' you should use fully qualified reference here
' WORKSHEET_NAME: the name of the worksheet where the L column is
Set active_sheet = ThisWorkbook.Worksheets("WORKSHEET_NAME")
With active_sheet
last_row = .Range("L" & .Rows.Count).End(xlUp).Row
Set packages_range = .Range("L2", .Cells(last_row, "L"))
End With
For Each cell In packages_range
Select Case cell.Value
Case "big box": cell.Interior.Color = vbRed
Case "small box": cell.Interior.Color = vbRed
End Select
Next cell
Set packages_range = Nothing
Set cell = Nothing
End Sub
I have been trying to develop a code which highlights the Range(A to M) where Col"A" <> "" but my code just highlights the ColA how to add the range to code.
Any help will be appreciated.
Sub formatcell()
Dim Report As Worksheet
Dim lastRow As Integer
Dim i As Integer
Set Report = ActiveSheet
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastRow
If Report.Cells(i, 1).Value <> "" Then
Report.Cells(i, 1).Interior.Color = RGB(255, 217, 102)
End If
Next i
End Sub
Try like this:
Dim ws As Worksheet, rng As Range
Set ws = ActiveSheet
On Error Resume Next 'skip error if no values
Set rng = ws.Columns("A").SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If Not rng Is Nothing Then
Application.Intersect(rng.EntireRow, ws.Range("A:M")).Interior.Color = vbYellow
End If
I want to highlight cells with the largest value in each row but only using columns F, I, L, O and R.
Sub Highlights()
Dim ws As Worksheet
Dim ColorRng As Range
Dim ColorCell As Range
Set ws = Worksheets("Sheet2")
Set ColorRng = ws.Range("F7,I7,L7,O7,R7")
'highlight the cell that contains the highest and lowest number
For Each ColorCell In ColorRng
If ColorCell.Value = Application.WorksheetFunction.Max(ColorRng) Then
ColorCell.Interior.Color = RGB(0, 180, 40)
ElseIf ColorCell.Value = Application.WorksheetFunction.Min(ColorRng) Then
ColorCell.Interior.Color = RGB(255, 0, 0)
End If
Next
End Sub
It works for the first row (that being row 7), but it doesn't continue to the next row. I realize this is because of my ColorRng range.
How do I allow the range to include more?
Please try this code.
Sub SetHighlights()
Dim ColorRng As Range
Dim ColorCell As Range ' loop object
Dim Mini As Variant
Dim Maxi As Variant
Dim R As Long ' loop counter: rows
Dim C As Long ' loop counter: columns
Dim n As Integer ' result counter
'highlight the cell that contains the highest and lowest number
Application.ScreenUpdating = False
With Worksheets("Sheet2")
For R = 2 To .Cells(.Rows.Count, "F").End(xlUp).Row
Set ColorRng = Union(.Cells(R, "F"), .Cells(R, "I"), _
.Cells(R, "L"), .Cells(R, "R"))
Mini = Application.Min(ColorRng)
Maxi = Application.Max(ColorRng)
For Each ColorCell In ColorRng
With ColorCell
If .Value = Maxi Then
.Interior.Color = RGB(0, 180, 40)
n = n + 1
ElseIf .Value = Mini Then
.Interior.Color = RGB(255, 0, 0)
n = n + 1
End If
End With
If n = 2 Then Exit For
Next ColorCell
Next R
End With
Application.ScreenUpdating = True
End Sub
Observe that the Min and Max functions are run only once per row instead of for each cell as your original code had it. Turning off ScreenUpdating further enhances the speed with which the procedure can complete the job
Give a try on below sub. As you need to highlight in every row, so you have to iterate every row to compare.
Sub Highlights()
Dim ws As Worksheet
Dim ColorRng As Range
Dim ColorCell As Range
Dim lRow As Long
Set ws = Worksheets("Sheet2")
lRow = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row
With ws
For i = 7 To lRow
Set ColorRng = Union(.Range("F" & i), .Range("I" & i), .Range("L" & i), .Range("O" & i), .Range("R" & i))
For Each ColorCell In ColorRng
If ColorCell.Value = Application.Max(ColorRng) Then
ColorCell.Interior.Color = RGB(0, 180, 40)
ElseIf ColorCell.Value = Application.Min(ColorRng) Then
ColorCell.Interior.Color = RGB(255, 0, 0)
End If
Next ColorCell
Set ColorRng = Nothing
Next i
End With
End Sub
Highlight Mins and Maxes
If error values, it will fail.
If no numeric value, then no color.
If max = min, then max color.
Adjust the values in the constants section.
The Code
Option Explicit
Sub highlightMinMax()
Const wsName As String = "Sheet2"
Const FirstRow As Long = 7
Const LastRowColumn As String = "F"
Const ColsList As String = "F,I,L,O,R"
Dim ColorMin As Long: ColorMin = RGB(255, 0, 0) ' 255
Dim ColorMax As Long: ColorMax = RGB(0, 180, 40) ' 2667520
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim rgCols As Range
Dim LastRow As Long
Dim i As Long
Set rgCols = ws.Columns(LastRowColumn)
LastRow = ws.Cells(ws.Rows.Count, LastRowColumn).End(xlUp).Row
If LastRow < FirstRow Then Exit Sub
Dim Cols() As String: Cols = Split(ColsList, ",")
For i = 0 To UBound(Cols)
Set rgCols = getCombinedRangeBasic(rgCols, ws.Columns(Cols(i)))
Next i
Erase Cols
Dim rgColor As Range
Dim cel As Range
Dim rgMin As Range
Dim rgMax As Range
Dim cMin As Double
Dim cMax As Double
For i = FirstRow To LastRow
Set rgColor = Intersect(rgCols, ws.Rows(i))
cMax = Application.Max(rgColor)
cMin = Application.Min(rgColor)
For Each cel In rgColor
If cel.Value = cMax Then
Set rgMax = getCombinedRangeBasic(rgMax, cel)
ElseIf cel.Value = cMin Then
Set rgMin = getCombinedRangeBasic(rgMin, cel)
End If
Next
Next i
If Not rgMin Is Nothing Then
rgMin.Interior.Color = ColorMin
End If
If Not rgMax Is Nothing Then
rgMax.Interior.Color = ColorMax
End If
End Sub
Function getCombinedRangeBasic( _
ByVal BuiltRange As Range, _
ByVal AddRange As Range)
If BuiltRange Is Nothing Then
Set getCombinedRangeBasic = AddRange
Else
Set getCombinedRangeBasic = Union(BuiltRange, AddRange)
End If
End Function
This proposed solution uses FormatConditions
FormatConditions will keep the Mins & Maxs updated when ever the values get changed.
Only need to rerun the procedure when the range changes.
However, FormatConditions are Volatile therefore need to evaluate the size of your data.
…
Sub FormatConditions_MinMax_NonContiguousRow()
Const kIni As Byte = 7
Dim Rng As Range, rRow As Range, lRow As Long
With ThisWorkbook.Sheets("Sheet2") 'Change as required
Rem Disable AutoFilter
If Not (.AutoFilter Is Nothing) Then .AutoFilter.Range.AutoFilter
Rem Set & Validate Last Row
lRow = .Columns("F").Cells(.Rows.Count).End(xlUp).Row
If lRow <= kIni Then Exit Sub
Rem Set Data Range
Set Rng = .Range("F" & kIni & ":R" & lRow)
End With
With Rng
Rem Delete prior FormatConditions
.FormatConditions.Delete
Rem Add FormatConditions by Row
For Each rRow In .Rows
With rRow
Rem Add FormatConditions Max
With .FormatConditions.AddTop10
.SetFirstPriority
.TopBottom = xlTop10Top
.Rank = 1
.Percent = False
.Interior.Color = RGB(255, 0, 0)
.StopIfTrue = True
End With
Rem FormatConditions Min
With .FormatConditions.AddTop10
.SetFirstPriority
.TopBottom = xlTop10Bottom
.Rank = 1
.Percent = False
.Interior.Color = RGB(0, 180, 40)
.StopIfTrue = True
End With
End With: Next
Rem Remove FormatConditions from Other Columns
Application.Intersect(.Cells, Range("G:H,J:K,M:N,P:Q")).FormatConditions.Delete
.Calculate
End With
End Sub
I have the below code that copies numbers (that doesn't have a color) from a range (here D3 to D30) and pastes it into F column staring from row 1 and does some percentile calculation.
Problem is, I noticed that a stray number "5" appears in F column in the first row even though there is no such number in my range D3 - D30.
Sub TPNoRedpass50tablet()
Dim cel As Range
Dim Rng As Range
Dim arr As Variant
Dim i As Long
Application.ScreenUpdating = False
For Each cel In Sheets("TP").Range("TP!$D$3:$D$30")
If cel.Font.Color = 0 Then
If Rng Is Nothing Then
Set Rng = cel
Else
Set Rng = Union(cel, Rng)
End If
End If
Next cel
ReDim arr(Rng.count - 1)
If Not Rng Is Nothing Then
For Each cel In Rng
arr(i) = cel
i = i + 1
Next cel
Sheets("TP").Range("F1").Resize(UBound(arr) + 1).Value = Application.Transpose(arr)
Set Rng = Sheets("TP").Range("F1:I" & Sheets("TP").Cells(Rows.count, "F").End(xlUp).Row)
Sheets("WBR").Range("AH101").Formula = "=PERCENTILE.INC(" & Rng.Address(, , , True) & ",50%)*24"
Sheets("WBR").Range("AH101").Value = Sheets("WBR").Range("AH101").Value
End If
Application.ScreenUpdating = True
End Sub
Try this:
Sub TPNoRedpass50tablet()
Dim cel As Range
Dim Rng As Range
Dim arr As Variant
Dim i As Long
Application.ScreenUpdating = False
For Each cel In Sheets("TP").Range("TP!$D$3:$D$30")
If Rng Is Nothing Then
Set Rng = cel
If cel.Font.Color = 0 Then
Else
Set Rng = Union(cel, Rng)
End If
End If
Next cel
ReDim arr(Rng.count - 1)
If Not Rng Is Nothing Then
For Each cel In Rng
arr(i) = cel
i = i + 1
Next cel
Sheets("TP").Range("F1").Resize(UBound(arr) + 1).Value = Application.Transpose(arr)
Set Rng = Sheets("TP").Range("F1:I" & Sheets("TP").Cells(Rows.count, "F").End(xlUp).Row)
Sheets("WBR").Range("AH101").Formula = "=PERCENTILE.INC(" & Rng.Address(, , , True) & ",50%)*24"
Sheets("WBR").Range("AH101").Value = Sheets("WBR").Range("AH101").Value
End If
Application.ScreenUpdating = True
End Sub
The problem seems to be in the first for each loop. You have a union, which is carried out only the first time, when Rng is not set.
Sub sel_to_array()
Dim arr As Variant
Dim i
Sheets("Ps").Activate
Sheets("Ps").Range("C6").Select
Range(Selection, Selection.End(xlDown)).Select
'arr = ActiveCell.CurrentRegion.Value
arr = Selection
For Each i In arr
MsgBox i
If Round(i, 0) = Round(proj_cbox.Value, 0) Then
GoTo 1:
End If
Next i
End Sub
Here is what it does: when it finds the equal match, I want to know what its cell location is, for example A3 or A13.
Try this
Sub sel_to_array()
Dim arr As Range, rng As Range, cell As Range
Dim lastRow As Long
Sheets("Ps").Activate
lastRow = Sheets("Ps").Range("C" & Rows.Count).End(xlUp).Row
If lastRow <= 5 Then Exit Sub
Set rng = Range("C6:C" & lastRow)
For Each cell In rng
If Round(cell.Value, 0) = Round(proj_cbox.Value, 0) Then
MsgBox cell.Address
End If
Next
End Sub
Not sure why you are bouncing the range to an array. If that is not really needed you could try this:
Sub sel_to_address()
Dim MyRange As Range
For Each MyRange In Range(Sheets("Ps").Range("C6"), Sheets("Ps").Range("C6").End(xlDown))
MsgBox MyRange.Value
If Round(MyRange.Value, 0) = Round(proj_cbox.Value, 0) Then
MsgBox MyRange.Address
End If
Next MyRange
End Sub
Try:
MsgBox i.Address
or you could do this
Set arr = Selection 'set here forces arr to a range object
If Round(i, 0) = Round(proj_cbox.Value, 0) Then
With i.Interior
.Pattern = xlSolid
.ColorIndex = 36 'Light Yellow
End With
Else
i.Interior.ColorIndex = xlNone
End If
which will shade all cells with light yellow that match the value, and clear shading from all cells that don't.