I wanted to know how to apply conditional formatting rules using vba...
I have the following dataset:
As you can see the first column is the UNIQUE_ACCOUNT_NUMBER which consists usually in two matching records, followed by other columns showing data related to the account numbers.
I want to apply a conditional formatting rule that if UNIQUE_ACCOUNT_NUMBER is matching, but any other column isnt(for the two matching records) then I want to highlight it yellow.
For example:
As you can see the account number MTMB^1^10000397 was matching twice but the Arrears_flag wasnt matching so i want to highlight it yellow.
I hope this makes sense.
In this example I can only apply the match & Mismatch for one column...
Dim rg1 As Range
Set rg1 = Range("E3", Range("E3").End(xlDown))
Dim uv As UniqueValues
Set uv = rg1.FormatConditions.AddUniqueValues
uv.DupeUnique = xlDuplicate
uv.Interior.Color = vbRed
Thanks!
I managed to get it working, adding a new helper column, concatenating the account number and the "ACC_HEADER_POOL" column in column "I", and using =COUNTIF(I$2:I$5,I2)=1 as the formula on which the conditional formatting is based, as you can see in this screenshot:
Please find the answer
Sub actin()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = 2 To Sheet1.Cells(Rows.Count, "E").End(xlUp).Row
mrow = 0
If Application.WorksheetFunction.CountIf(Sheet1.Range(Sheet1.Cells(1, "E"), Sheet1.Cells(i - 1, "E")), Sheet1.Cells(i, "E")) > 0 Then
mrow = Application.WorksheetFunction.Match(Sheet1.Cells(i, "E"), Sheet1.Range(Sheet1.Cells(1, "E"), Sheet1.Cells(i - 1, "E")), 0)
End If
If mrow = 0 Then GoTo eee
If Sheet1.Cells(i, "G") <> Sheet1.Cells(mrow, "G") Then
Sheet1.Cells(i, "G").Interior.Color = vbYellow
Sheet1.Cells(mrow, "G").Interior.Color = vbYellow
End If
If Sheet1.Cells(i, "H") <> Sheet1.Cells(mrow, "H") Then
Sheet1.Cells(i, "H").Interior.Color = vbYellow
Sheet1.Cells(mrow, "H").Interior.Color = vbYellow
End If
eee:
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Related
I have a spreedsheet with more than 200k rows and 85 columns. I need to change the column type to a specify format for each Column if the Column Name is found on another Sheet. The problem is, the code below is taking more than 25 min to finish.
aTemplate = The Sheet with I have the Column name and Types
aTemplate2 = The Sheet with my Data which I need to format each Column
Is it possible to improve this method? See the code Below.
aTemplate = Worksheets("Format Parameters").Range("A2", Worksheets("Format Parameters").Cells(Rows.Count, "B").End(xlUp))
aTemplate2 = Worksheets("DADOS").Range("A1", Worksheets("DADOS").Cells(Rows.Count, "CI").End(xlUp))
lCount2 = UBound(aTemplate2, 1)
For cCount2 = LBound(aTemplate2, 2) To UBound(aTemplate2, 2)
For lCount = LBound(aTemplate, 1) To UBound(aTemplate, 1)
If aTemplate(lCount, 1) = aTemplate2(1, cCount2) Then 'Compare Column name
For i = 2 To lCount2 'for each row
Select Case aTemplate(lCount, 2) ' Verify the type which I need to change the column
Case "Text"
With ActiveCell(i, cCount2)
.NumberFormat = "#"
.Value = .Value
End With
Case "Integer"
With ActiveCell(i, cCount2)
.NumberFormat = "0"
.Value = .Value
End With
Case "Date"
With ActiveCell(i, cCount2)
.NumberFormat = "mm/dd/yyyy"
.Value = .Value
End With
Case "Decimal"
With ActiveCell(i, cCount2)
.NumberFormat = "0.000"
.Value = .Value
End With
Case Else
End Select
Next i
Exit For
End If
Next
Next
End Sub
I believe that the ActiveCell Method is why is taking so much to run this function.
Something like the following should be exponentially faster.
Loop over each column in the main table.
Look up the column name (using Match) in the first column of the lookup table.
Return the corresponding format type from the second column of the lookup table.
Apply the corresponding number format to the entire column of the main table.
With Worksheets("Format Parameters")
Dim aTemplate As Range
Set aTemplate = .Range("A2", .Cells(.Rows.Count, "B").End(xlUp))
End With
With Worksheets("DADOS")
Dim aTemplate2 As Range
Set aTemplate2 = .Range("A1", .Cells(.Rows.Count, "CI").End(xlUp))
End With
With aTemplate2
Dim col As Range
For Each col In .Columns
Dim matchRow
matchRow = Application.Match(col.Cells(1).Value, aTemplate.Columns(1), 0)
If Not IsError(matchRow) Then
With col.Offset(1).Resize(.Rows.Count - 1)
Select Case aTemplate.Columns(2).Cells(matchRow).Value
Case "Text"
.NumberFormat = "#"
.Value = .Value
Case "Integer"
.NumberFormat = "0"
.Value = .Value
Case "Date"
.NumberFormat = "mm/dd/yyyy"
.Value = .Value
Case "Decimal"
.NumberFormat = "0.000"
.Value = .Value
End Select
End With
End If
Next
End With
The problem is that there are duplicated values in the first column (ISIN numbers of financial products), but different characteristics in the other columns (i.e. different product name, different modified duration etc.) where should be the same characteristics.
I wanted to find ISIN numbers that already exist in my first column (at least two times), then take specific elements from the other columns (of the same row that was found the duplicated value) such as issuer name, modified duration etc. and paste them to the other's ISIN elements in order to report the same elements (data in other columns) in case where ISIN numbers are the same.
I also wanted to compare the modified duration of these duplicated products and take the bigger one (for conservative reasons, because these data are used in further calculations).
Sub dup_cp()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Sheets("Investment Assets").Activate
j = Application.CountA(Range("A:A"))
'counts the number of filled in rows
For i = 5 To j
'it starts from line 5 on purpose, the ISIN numbers start from that line
For k = i + 1 To j
If Sheets("Investment Assets").Range(Cells(k, 55), Cells(k, 55)).Value = "Duplicate Value" Then GoTo skip_dup
'it skips the line that has already been detected as duplicated
If Sheets("Investment Assets").Range(Cells(k, 1), Cells(k, 1)).Value = Sheets("Investment Assets").Range(Cells(i, 1), Cells(i, 1)).Value Then
'it finds the duplicate value (ISIN number) in the first column
If Sheets("Investment Assets").Range(Cells(k, 29), Cells(k, 29)).Value >= Sheets("Investment Assets").Range(Cells(i, 29), Cells(i, 29)).Value Then
'it compares the 29th column values (the modified duration of the components) and keeps the bigger value for prudency reasons
Sheets("Investment Assets").Range(Cells(k, 15), Cells(k, 32)).Copy
Sheets("Investment Assets").Range(Cells(i, 15), Cells(i, 32)).PasteSpecial Paste:=xlPasteValues
Else
Sheets("Investment Assets").Range(Cells(i, 15), Cells(i, 32)).Copy
Sheets("Investment Assets").Range(Cells(k, 15), Cells(k, 32)).PasteSpecial Paste:=xlPasteValues
End If
Sheets("Investment Assets").Range(Cells(k, 55), Cells(k, 55)).Value = "Duplicate Value"
'it shows in the 55th column if the ISIN number is duplicated or not
Sheets("Investment Assets").Range(Cells(i, 55), Cells(i, 55)).Value = "Duplicate Value"
Else
Sheets("Investment Assets").Range(Cells(k, 55), Cells(k, 55)).Value = "-"
End If
skip_dup:
Next
Next
End Sub
This code works, but is a bit messy and I'm apologizing for that.
Thanks in advance for everyone who will take a time to make it more simple and faster.
I think it will help any actuary or risk manager who works in Solvecy II environment.
Changed a few things. As said before, Copy and Activate are the biggest drags on performance. I have introduced a With statement instead of Activate and have changed Copy, Paste to a faster ....Value = ....Value
Sub dup_cp()
Dim i As Integer
Dim j As Integer
Dim k As Integer
With Sheets("Investment Assets")
j = Application.CountA(.Range("A:A"))
'counts the number of filled in rows
For i = 5 To j
'it starts from line 5 on purpose, the ISIN numbers start from that line
For k = i + 1 To j
If .Cells(k, 55).Value = "Duplicate Value" Then GoTo skip_dup
'it skips the line that has already been detected as duplicated
If .Cells(k, 1).Value = .Cells(i, 1).Value Then
'it finds the duplicate value (ISIN number) in the first column
If .Cells(k, 29).Value >= .Cells(i, 29).Value Then
'it compares the 29th column values (the modified duration of the components) and keeps the bigger value for prudency reasons
.Range(.Cells(i, 15), .Cells(i, 32)).Value = .Range(.Cells(k, 15), .Cells(k, 32)).Value
Else
.Range(.Cells(k, 15), .Cells(k, 32)).Value = .Range(.Cells(i, 15), .Cells(i, 32)).Value
End If
.Cells(k, 55).Value = "Duplicate Value"
'it shows in the 55th column if the ISIN number is duplicated or not
.Cells(i, 55).Value = "Duplicate Value"
Else
.Cells(k, 55).Value = "-"
End If
skip_dup:
Next
Next
End With
End Sub
Old Nick's proposal is also very great for performance, but I would implement it with care, something like this:
Sub xxx
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
'Your code
ErrorHandler:
If Err.Number <> 0 Then MsgBox Err.Number & " " & Err.Description
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
Because if you disable those things at the beginning, and then suddenly something goes wrong in the code, you might not get those things re-enabled.
Without changing anything you've done (as after all you say it works), you could try disabling some of the automatic features of Excel before you call your sub:
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
And then re-enabling them when you return from your sub:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Hopefully you should see an improvement in execution speed by doing this
In column A and B there will be numbers entered manually. column C gives out the sum automatically.
I would like to program in excel-VBA the following:
the colour of the cells in column C changes depending on the entered
numbers in A and B:
when the sum of cell A and B is less than 5: red
when the sum of the values in A and B is at least 5 AND value in cell B is at least 2: green
I think of using offset but I don't know how or if this would be the right command.
Thank you so much in advance, I am new to excel-vba and I don't know how to program it, and it will help me a lot to dig deeper into this programming language!
A non-VBA method:
Select cell C2 (the first cell to apply formatting to).
Select Conditional Formatting from the Home ribbon.
Select New Rule.
Select Use a formula to determine which cells to format.
Add the formula =SUM($A2:$B2)<5 and change the format to red.
Click OK.
Select New Rule again.
Select Use a formula to determine which cells to format.
Add the formula =AND(SUM($A2:$B2)>=5,$B2>=2) and change the format to green.
Click OK.
Select the Format Painter from the Home ribbon and copy the format down, or drag the cell down to copy down.
Using VBA:
This code will update the font colour in column C when the values in column A:B are manually updated. If you want the cells to update based on a formula you'll have to use the Worksheet_Calculate and check each value in columns A:B.
Private Sub Worksheet_Change(ByVal Target As Range)
'Check that a value is being changed in column A:B.
If Not Intersect(Target, Columns(1).Resize(, 2)) Is Nothing Then
With Target
'Check both values are numbers.
If IsNumeric(Cells(.Row, 1)) And IsNumeric(Cells(.Row, 2)) Then
'Change colour based on numeric values.
If Cells(.Row, 1) + Cells(.Row, 2) < 5 Then
Cells(.Row, 3).Font.Color = RGB(255, 0, 0)
ElseIf Cells(.Row, 1) + Cells(.Row, 2) >= 5 And Cells(.Row, 2) >= 2 Then
Cells(.Row, 3).Font.Color = RGB(0, 255, 0)
Else
Cells(.Row, 3).Font.Color = RGB(0, 0, 0)
End If
Else
'If not numeric change font to black.
Cells(.Row, 3).Font.Color = RGB(0, 0, 0)
End If
End With
End If
End Sub
Use conditional formatting applied through VBA or manually on the worksheet's Home tab.
Option Explicit
Sub rgy()
With Worksheets("sheet1")
With .Range("C:C")
With .FormatConditions
.Delete
With .Add(Type:=xlExpression, Formula1:="=AND(COUNT($A1:$B1)=2, SUM($A1:$B1)=0)")
.Interior.Color = vbRed
End With
With .Add(Type:=xlExpression, Formula1:="=AND(COUNT($A1:$B1)=2, SUM($A1:$B1)>=5)")
.Interior.Color = vbGreen
End With
With .Add(Type:=xlExpression, Formula1:="=AND(COUNT($A1:$B1)=2, SUM($A1:$B1)>0, SUM($A1:$B1)<5)")
.Interior.Color = vbYellow
End With
End With
End With
End With
End Sub
Try this macro;
Dim cel As Range, lRow As Long
lRow = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row
For Each cel In Range("C2:C" & lRow)
If cel.Value < "5" Then cel.Interior.Color = vbRed
If cel.Value = "5" Or cel.Offset(, -1).Value >= "2" Then cel.Interior.Color = vbGreen
Next cel
You could easily use conditional formatting
Try:
Option Explicit
Sub Test()
Dim LastRow As Long, i As Long
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow
If .Range("C" & i).Value < 5 Then
.Range("C" & i).Interior.Color = vbRed
ElseIf .Range("C" & i).Value >= 5 And .Range("B" & i).Value >= 2 Then
.Range("C" & i).Interior.Color = vbGreen
End If
Next i
End With
End Sub
Could someone please help me with some code to delete all duplicate entries across multiple columns and rows. Any cell which has a duplicate value I'd like to be blank, but I do not want to delete the cell and shift all the rows up like the remove duplicates button does. I'd like code exactly like conditional formatting does to highlight cells, but I'd like to set the value to "" instead.
I'm trying to edit the macro I recorded to something like:
Columns("I:R").Select
selection.FormatConditions.AddUniqueValues
selection.FormatConditions(1).DupeUnique = xlDuplicate
selection.FormatConditions(1).Value = ""
But I'm not sure I'm on the right track
Start at the bottom and work towards the top. Take a ten-column-conditional COUNTIFS function of the cell values while shortening the rows examined by 1 every loop.
Sub clearDupes()
Dim rw As Long
With Worksheets("Sheet1")
If .AutoFilterMode Then .AutoFilterMode = False
With Intersect(.Range("I:R"), .UsedRange)
.Cells.Interior.Pattern = xlNone
For rw = .Rows.Count To 2 Step -1
With .Resize(rw, .Columns.Count) 'if clear both then remove this
If Application.CountIfs(.Columns(1), .Cells(rw, 1), .Columns(2), .Cells(rw, 2), _
.Columns(3), .Cells(rw, 3), .Columns(4), .Cells(rw, 4), _
.Columns(5), .Cells(rw, 5), .Columns(6), .Cells(rw, 6), _
.Columns(7), .Cells(rw, 7), .Columns(8), .Cells(rw, 8), _
.Columns(9), .Cells(rw, 9), .Columns(10), .Cells(rw, 10)) > 1 Then
'test with this
.Rows(rw).Cells.Interior.Color = vbRed
'clear values with this once it has been debugged
'.Rows(rw).Cells.ClearContents
End If
End With 'if clear both then remove this
Next rw
End With
If .AutoFilterMode Then .AutoFilterMode = False
End With
End Sub
I've left some code in that only marks the potential duplicates. When you are happy with the results, change that to the commented code that actually clear the cell contents.
Using two sets of nested loops I check each cell in the range twice, once to see if it was a duplicate and to mark it and a second time to then remove the value (ensuring I remove all duplicates and do not leave one instance of each duplicate).
I'm sure that this is an inefficient way of doing it but it works so hopefully helps someone else in the same boat.
Private Sub CommandButton1_Click()
Dim Row As Integer
Dim Column As Integer
Row = 100
Column = 10
'loop through identifying the duplicated by setting colour to blue
For i = 1 To Row 'loops each row up to row count
For j = 1 To Column 'loops every column in each cell
If Application.CountIf(Range(Cells(4, 1), Cells(Row, Column)), Cells(i, j)) > 1 Then 'check each cell against entire range to see if it occurs more than once
Cells(i, j).Interior.Color = vbBlue 'if it does sets it to blue
End If
Next j
Next i
'loop through a second time removing the values in blue (duplicate) cells
For i = 1 To Row 'loops each row up to row count
For j = 1 To Column 'loops every column in each cell
If Cells(i, j).Interior.Color = vbBlue Then 'checks if cell is blue (i.e duplicate from last time)
Cells(i, j) = "" 'sets it to blank
Cells(i, j).Interior.Color = xlNone 'changes colour back to no fill
End If
Next j
Next i
End Sub
Use conditional format to highlight duplicates and then change the value to "" using a loop through selection.
This code will allow one value to remain.(if you have 25 twice, this code will keep one 25)
Option Explicit
Sub DupRem()
Application.ScreenUpdating = False
Dim rn As Range
Dim dup As Range
Columns("I:R").FormatConditions.AddUniqueValues
Columns("I:R").FormatConditions(1).DupeUnique = xlDuplicate
Columns("I:R").FormatConditions(1).Font.Color = RGB(255, 255, 0)
For Each rn In Columns("I:R").Cells
If rn <> "" Then
If rn.DisplayFormat.Font.Color = RGB(255, 255, 0) Then
If dup Is Nothing Then
Set dup = rn
Else
Set dup = Union(dup, rn)
End If
End If
End If
Next
dup.ClearContents
Columns("I:R").FormatConditions(1).StopIfTrue = False
Columns("I:R").FormatConditions.Delete
Application.ScreenUpdating = True
End Sub
I wanted to color highlight cells that are different from each other; in this case colA and colB. This function works for what I need, but looks repetitive, ugly, and inefficient. I'm not well versed in VBA coding; Is there a more elegant way of writing this function?
EDIT
What I'm trying to get this function to do is:
1. highlight cells in ColA that are different or not in ColB
2. highlight cells in ColB that are different or not in ColA
Sub compare_cols()
Dim myRng As Range
Dim lastCell As Long
'Get the last row
Dim lastRow As Integer
lastRow = ActiveSheet.UsedRange.Rows.Count
'Debug.Print "Last Row is " & lastRow
Dim c As Range
Dim d As Range
Application.ScreenUpdating = False
For Each c In Worksheets("Sheet1").Range("A2:A" & lastRow).Cells
For Each d In Worksheets("Sheet1").Range("B2:B" & lastRow).Cells
c.Interior.Color = vbRed
If (InStr(1, d, c, 1) > 0) Then
c.Interior.Color = vbWhite
Exit For
End If
Next
Next
For Each c In Worksheets("Sheet1").Range("B2:B" & lastRow).Cells
For Each d In Worksheets("Sheet1").Range("A2:A" & lastRow).Cells
c.Interior.Color = vbRed
If (InStr(1, d, c, 1) > 0) Then
c.Interior.Color = vbWhite
Exit For
End If
Next
Next
Application.ScreenUpdating = True
End Sub
Ah yeah that's cake I do it all day long. Actually your code looks pretty much like the way I'd do it. Although, I opt to use looping through integers as opposed to using the "For Each" method. The only potential problems I can see with your code is that ActiveSheet may not always be "Sheet1", and also InStr has been known to give some issues regarding the vbTextCompare parameter. Using the given code, I would change it to the following:
Sub compare_cols()
'Get the last row
Dim Report As Worksheet
Dim i As Integer, j As Integer
Dim lastRow As Integer
Set Report = Excel.Worksheets("Sheet1") 'You could also use Excel.ActiveSheet _
if you always want this to run on the current sheet.
lastRow = Report.UsedRange.Rows.Count
Application.ScreenUpdating = False
For i = 2 To lastRow
For j = 2 To lastRow
If Report.Cells(i, 1).Value <> "" Then 'This will omit blank cells at the end (in the event that the column lengths are not equal.
If InStr(1, Report.Cells(j, 2).Value, Report.Cells(i, 1).Value, vbTextCompare) > 0 Then
'You may notice in the above instr statement, I have used vbTextCompare instead of its numerical value, _
I find this much more reliable.
Report.Cells(i, 1).Interior.Color = RGB(255, 255, 255) 'White background
Report.Cells(i, 1).Font.Color = RGB(0, 0, 0) 'Black font color
Exit For
Else
Report.Cells(i, 1).Interior.Color = RGB(156, 0, 6) 'Dark red background
Report.Cells(i, 1).Font.Color = RGB(255, 199, 206) 'Light red font color
End If
End If
Next j
Next i
'Now I use the same code for the second column, and just switch the column numbers.
For i = 2 To lastRow
For j = 2 To lastRow
If Report.Cells(i, 2).Value <> "" Then
If InStr(1, Report.Cells(j, 1).Value, Report.Cells(i, 2).Value, vbTextCompare) > 0 Then
Report.Cells(i, 2).Interior.Color = RGB(255, 255, 255) 'White background
Report.Cells(i, 2).Font.Color = RGB(0, 0, 0) 'Black font color
Exit For
Else
Report.Cells(i, 2).Interior.Color = RGB(156, 0, 6) 'Dark red background
Report.Cells(i, 2).Font.Color = RGB(255, 199, 206) 'Light red font color
End If
End If
Next j
Next i
Application.ScreenUpdating = True
End Sub
Things I did differently:
I used my integer method described above (as opposed to the 'for each' method).
I defined the worksheet as an object variable.
I used vbTextCompare instead of its numerical value in the InStr function.
I added an if statement to omit blank cells. Tip: Even if only one
column in the sheet is extra long (e.g., cell D5000 was accidentally
formatted), then the usedrange for all columns is considered 5000.
I used rgb codes for the colors (it's just easier for me since I
have a cheat sheet pinned to the wall next to me in this cubicle
haha).
Well that about sums it up. Good luck with your project!
'Compare the two columns and highlight the difference
Sub CompareandHighlight()
Dim n As Integer
Dim valE As Double
Dim valI As Double
Dim i As Integer
n = Worksheets("Indices").Range("E:E").Cells.SpecialCells(xlCellTypeConstants).Count
Application.ScreenUpdating = False
For i = 2 To n
valE = Worksheets("Indices").Range("E" & i).Value
valI = Worksheets("Indices").Range("I" & i).Value
If valE = valI Then
Else:
Worksheets("Indices").Range("E" & i).Font.Color = RGB(255, 0, 0)
End If
Next i
End Sub
' I hope this helps you