i am a newbie in VBA, so i come across with several issues.
I have a dataset that looks like this:
I have to compare column A with columns B,C,D,E and F and then color the fonts of the cells in columns B:F under these conditions:
If cells in column A are equal with the cells in columns B:F, paint their font orange.
If cells in column A are higher than the cells in columns B:F, paint their font red.
If cells in column A are lower than the cells in columns B:F, paint their font green.
If the absolute difference between column A and the rest columns (B:F) is less than 1, paint their font orange.
I have tried to write a simple macro and all conditions are met except the 4th.
Here is my attempt.
Sub ConditionalFormating()
Dim i, j, a As Double
a = 0.99
i = 2
j = 2
For j = 1 To 6
For i = 2 To 10
ActiveSheet.Cells(i, j).Select
If ActiveSheet.Cells(i, j) - ActiveSheet.Cells(i, 1) >= a Then
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = RGB(255, 156, 0)
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
If ActiveSheet.Cells(i, j) - ActiveSheet.Cells(i, 1) <= a Then
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = RGB(255, 156, 0)
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
If ActiveSheet.Cells(i, j) > ActiveSheet.Cells(i, 1) Then
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = RGB(0, 255, 0)
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
If ActiveSheet.Cells(i, j) < ActiveSheet.Cells(i, 1) Then
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = RGB(255, 0, 0)
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
Next
Next
End Sub
Could anyone help me? I cannot understand why the 4th condition is not met when all others are.
Thank you in advance!
To color the font, you have to use the Font property of Range, like: Selection.Font.Color=RGB(255,128,0).
you could try this (commented) code:
Option Explicit
Sub ConditionalFormating()
Dim cell As Range, cell2 As Range, dataRng As Range
Dim colOrange As Long, colRed As Long, colGreen As Long, col As Long
colOrange = RGB(255, 156, 0)
colRed = RGB(255, 0, 0)
colGreen = RGB(0, 255, 0)
With Worksheets("CF") '<--| reference the relevant worksheet (change "CF" to your actual worksheet name)
Set dataRng = Intersect(.Columns("B:F"), .UsedRange)
For Each cell In .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants) '<-- loop through its column "A" not empty cells from row 1 down to last not empty one
If WorksheetFunction.CountA(Intersect(dataRng, cell.EntireRow)) > 0 Then ' if current row has data
For Each cell2 In Intersect(dataRng, cell.EntireRow).SpecialCells(xlCellTypeConstants) ' loop through current column "A" cell row not empty cells
Select Case True '<-- check the current datum against the following conditions
Case cell2.Value = cell.Value Or Abs(cell.Value - cell2.Value) < 1 'if current datum equals corresponding value in column "A" or their absolute difference is lower than 1
col = colOrange
Case cell2.Value < cell.Value 'if current datum is lower then corresponding value in column "A"
col = colRed
Case cell2.Value > cell.Value 'if current datum is higher then corresponding value in column "A"
col = colGreen
End Select
With cell2.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = col
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Next cell2
End If
Next cell
End With
End Sub
Related
I am writing the code below in VBA macro excel, my problem is that I get the object our of range error in the line (107, col 10) and I don't know why.
the line I get the error
.Range(.Cells(x, "A"), .Cells(x, "AC")).Select
my code is below
Sub MRP()
'
' Macro1 Macro
'
'
Dim wks As Worksheet
Dim OPwks As Worksheet
Dim MRPwks As Worksheet
Dim OPDwks As Worksheet
Dim DbCwks As Worksheet
Dim x As Long
Dim p As Integer, i As Long, q As Long
Dim a As Integer, m As Integer, k As Long
Dim rowRange As Range
Dim colRange As Range
Dim LastCol As Long
Dim LastRowOPwks As Long
Dim LastRowMRPwks As Long
Dim LastRowDBCwks As Long
Set MRPwks = Worksheets("MRP")
Set OPwks = Worksheets("OpenPOsReport")
Set DbCwks = Worksheets("CompDB")
Set wks = ActiveSheet
Worksheets("OpenPOsReport").Activate
LastRowMRPwks = MRPwks.Cells(MRPwks.Rows.Count, "A").End(xlUp).Row
LastRowOPwks = OPwks.Cells(OPwks.Rows.Count, "A").End(xlUp).Row
LastRowDBCwks = DbCwks.Cells(DbCwks.Rows.Count, "A").End(xlUp).Row
'Set rowRange = wks.Range("A1:A" & LastRow)
'For m = 8 To LastRow
'Cells(m, "N") = 0
'Next m
For i = 2 To LastRowDBCwks
p = 0
For q = 8 To LastRowOPwks
If DbCwks.Cells(i, "V") = 0 Then k = 0 Else: k = p / Cells(i, "V")
If OPwks.Cells(q, "A") = DbCwks.Cells(i, "A") Then
If OPwks.Cells(q, "D") = 0 Or OPwks.Cells(q, "B") < 1 / 1 / 18
Then GoTo Nextiteration Else
If (OPwks.Cells(q, "C") + DbCwks.Cells(i, "C")) >=
(DbCwks.Cells(i, "F") + k) Then
OPwks.Cells(q, "N").Value = 1
OPwks.Range(Cells(q, "A"), Cells(q, "N")).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
p = p + OPwks.Cells(q, "D").Value
OPwks.Cells(q, "N").Value = 0
OPwks.Range(Cells(q, "A"), Cells(q, "O")).Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
End If
Nextiteration:
Next q
Next i
'For q = 8 To LastRow
' If Cells(q, "N") = 1 Then
' End If
' Next
With MRPwks
For x = 5 To LastRowMRPwks
If .Cells(x, "AC").Value > 0 Then
.Range(.Cells(x, "A"), .Cells(x, "AC")).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
If .Cells(x, "AC") = 0 Then
.Range(.Cells(x, "A"), .Cells(x, "AC")).Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
Next x
End With
End Sub
I dont know why I get the Object out of range error in the first part of the code.
You have Worksheets("OpenPOsReport").Activate in your code, then you try to select .Range(.Cells(x, "A"), .Cells(x, "AC")).Select on MRPwks which is not active at that time. This is not possible.
Change your code to
With MRPwks
For x = 5 To LastRowMRPwks
If .Cells(x, "AC").Value > 0 Then
With .Range(.Cells(x, "A"), .Cells(x, "AC")).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
If .Cells(x, "AC") = 0 Then
With .Range(.Cells(x, "A"), .Cells(x, "AC")).Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
Next x
End With
It is not neccessary to select the range first.
You can avoid this error if you don't try to Select the range (because you cannot select a range on a sheet that's inactive). One common mistake is to say "OK, well, then I'll just add a .Activate to make sure the right sheet is active. But that leads to spaghetti code, as you constantly need to keep track of which sheet in which workbook is active, makes the code hard to read and harder to debug.
Selecting/Activating things in Excel is almost never necessary, and when you do it this way it tends to cause all sorts of difficult-to-troubleshoot errors, like the one you have.
Dim rngToFormat as Range
For x = 5 To LastRowMRPwks
Set rngToFormat = .Cells(x, "A").Resize(1,29)
If rngToFormat.Cells(29).Value > 0 Then
With rngToFormat.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
With rngToFormat.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
Next x
I have a table from A1:C250. A1 is a merged cell that has the name of the table and A2,B2 and C2 are headers for the following rows. A3:A250, B3:B250 and C3:C250 is all data.
Some of the cells in B and C do not have any words, and I want to program a macro that will go through and highlight and delete the entire row if there is an empty cell in the table. I also want to make sure that the macro is not bound to only 250 rows, because I will be using this month to month and some months may have more or less than 250 data points.
Range("A3").Select
start = ActiveCell.Row
Selection.End(xlDown).Select
end = ActiveCell.Row
rng = Application.Range("A3:C"& end )
For Each cel In rng.Cells
If isEmpty(cel) Then
cel.Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
'Do nothing
End If
Next cel
I would like write a VBA code to select a group of cells that has the same value and colour it.
MySpreadSheet
For Row A, Staff ID, are the same, for the same person, I intend to scan through them and if they are the same, fill the cells with the light blue colour you see in the picture above, for Column A to MaxColumn of Current Region.
I have a drafted a code to do that but it does nothing when I run it. Any help will be appreciated:
Sub ActualColouring()
Dim SerialNumber As Integer
SerialNumber = 2 'this variable will be assign to the rows, ignore the header, start from 2
Do While Cells(1, SerialNumber).Value <> "" 'keep looping as long as cell is not blank
If Cells(1, SerialNumber).Value = Cells(1, SerialNumber + 1).Value Then 'if the value of the cell is the same as the cell below, then
Cells(1, SerialNumber).Select 'then select it
With Selection.Interior 'this line is the start of the fill colouring
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With 'end of fill colouring function
End If
SerialNumber = SerialNumber + 1 'move to the next cell
Loop 'loop until the end of current region
End Sub
Qualify the objects and avoid select
Sub ActualColouring()
Dim ws as Worksheet
Set ws = ThisWorkbook.Worksheets("mySheet") ' change name as needed
With ws
Dim SerialNumber As Long, lRow as Long
lRow = .Range("A" & .Rows.Count).End(xlup).Row
For SerialNumber = 2 to lRow
If .Cells(1, SerialNumber).Value = .Cells(1, SerialNumber + 1).Value Then
With .Cells(1, SerialNumber).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
End If
Next
End With
End Sub
I have to levels of coloring cells here. 1st is changing rows with 0 months of stock remaining to yellow cells. Then next is to change rows with Item status of expired, hold, or restricted. The green overrides the yellow if the case arises. I would like it to only color within the range of data, which is columns A-O. I know my code isn't too far off and just needs some adjustments. Also was wondering if just the fact that I have them listed in the correct order will produce the proper override of green over yellow.
'Months of stock remaining # <1 to yellow cell=========================
Set MoSR = Range("M7:M" & Cells(Rows.Count, "A").End(xlUp).Row)
For Each Cell In MoSR
Select Case Cell.Value
Case Is = "<1"
.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 10092543
End Select
Next
'Item status of expired,hold,and restricted to green cell==============
Set Istatus = Range("C7:C" & Cells(Rows.Count, "A").End(xlUp).Row)
For Each Cell In Istatus
Select Case Cell.Value
Case Is = "Expired,Hold,Restricted"
.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.599993896298105
End Select
Next
I've edited the code to be a little more accurate
'Months of stock remaining # <1 to yellow cell=========================
Set MoSR = Range("M7:M" & Cells(Rows.Count, "A").End(xlUp).Row)
For Each Cell In MoSR
Select Case Cell.Value
'Use the next statement if the cell contains a number such as 0
Case Is < 1
'Use this statement if the cell actually contains a string of "<1"
'Case Is = "<1"
With Range("A" & Cell.Row & ":O" & Cell.Row).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 10092543
End With
End Select
Next
'Item status of expired,hold,and restricted to green cell==============
Set Istatus = Range("C7:C" & Cells(Rows.Count, "A").End(xlUp).Row)
For Each Cell In Istatus
Select Case Cell.Value
Case "Expired", "Hold", "Restricted"
With Range("A" & Cell.Row & ":O" & Cell.Row).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.599993896298105
End With
End Select
Next
(Edited to fix the Case statement after I saw Thomas Inzina's answer.)
I wish to find a word in excel and highlight that cell.How to do it using VBA.
My code is highlighting the entire sheet.
Here is the code-
Sub Foreign_Lang_Converter()
Sheets("Sheet2").Select
Value = 0
i = 1
Do While (Cells(i, 2) <> "")
Value = Value + 1
i = i + 1
Loop
Count = 0
For j = 1 To Value
a = Cells(j, 1)
b = Cells(j, 2)
Sheets("Sheet1").Select
Cells.Select
Selection.Find What:=a
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
End With
Selection.Replace What:=a, Replacement:=b
Sheets("Sheet2").Select
Next j
End Sub
First, read this.
edit: This is not a solution to your overall task, however I'll leave it up since it is the solution to the issue you described with your original code (it colored the entire sheet).
Your problem here is that Selection.Find What:=a doesn't change the selection, it returns a range (that goes nowhere). Since the whole sheet is still selected, the next steps color the whole sheet. Try
With Sheets("Sheet1").Cells.Find(a)
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
End With
.Value = b
End With
This does only replace one occurrence though. Look into the .FindNext method or conditional formatting. Also it might be better to set the other search parameters (LookIn, LookAt, SearchOrder, and MatchByte) because they get saved. (see the remarks here)
edit: fixed code. Should work now.
I got the resolution,
The code would be like -
Sub Foreign_Lang_Converter()
Sheets("Sheet2").Select
Value = 0
i = 1
Do While (Cells(i, 2) <> "")
Value = Value + 1`enter code here`
i = i + 1
Loop
Count = 0
For j = 1 To Value
a = Cells(j, 1)
b = Cells(j, 2)
Sheets("Sheet1").Select
Cells.Select
Application.ReplaceFormat.Clear
With Application.ReplaceFormat.Font
.Subscript = False
.TintAndShade = 0
End With
With Application.ReplaceFormat.Interior
.PatternColorIndex = xlAutomatic
.Color = 5296274
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Replace What:=a, Replacement:=b, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=True
Sheets("Sheet2").Select
Next j
End Sub