I am comparing two columns A and B.
The columns A and B contains the ID from a Database.
The ID is 13 digits long, but most of the cases they are 11 digits long.
Case 1: If column A has an ID ABC02369000 and column B has an ID ABC02369000 the result is match.
Case 2: If column A has an ID ABC14285500 and column B has an ID ABC1428550000 the result is still match.
Case 3: If column A has an ID ABC15184200 and column B has an ID ABC15144200 the result is no match.
I would like to have a code for this criteria. If it is matched, then highlighted as green, else as red.
I have tried conditional formatting already. I would be glad, if I can have it in code.
Sub RangeTest()
Dim targetWorksheet As Worksheet
Dim i As Long
Dim totalrows As Integer
For i = 2 To 112
Set targetWorksheet = Worksheets("Preparation sheet")
With targetWorksheet
Cells(i, 3) = IIf(Cells(i, 1) = Cells(i, 2), "Yes", "NO")
Cells(i, 3).Interior.Color = IIf(Cells(i, 3) = "Yes", RGB(0, 255, 0), RGB(255, 0, 0))
End With
Next
End Sub
Try the code below:
Option Explicit
Sub RangeTest()
Dim targetWorksheet As Worksheet
Dim i As Long
Dim totalrows As Integer
For i = 2 To 112
Set targetWorksheet = Worksheets("Preparation sheet")
With targetWorksheet
If Left(.Cells(i, 1), 11) = Left(.Cells(i, 2), 11) Then
.Cells(i, 3) = "Yes"
.Cells(i, 3).Interior.Color = RGB(0, 255, 0)
Else
.Cells(i, 3) = "NO"
.Cells(i, 3).Interior.Color = RGB(255, 0, 0)
End If
End With
Next i
End Sub
Related
I want to know how to change row color of a number of rows base on the value in column 1. Lets say in A1 to A5 I have the value "100" and A6 to A10 I have the value "150", i want to be able to change the color of rows 1 to 5 to blue because A1 to A5 has the value "100" and so forth with A6 to A10 to another color because of value "150". Pretty much I need to change the color to the same if the value are the same. My code works but it just changes to all blue and not different color each time the value changes.
EDIT ANSWER:
Dim i As Long
Dim holder As String
Set UsedRng = ActiveSheet.UsedRange
FirstRow = UsedRng(1).Row
LastRow = UsedRng(UsedRng.Cells.Count).Row
r = WorksheetFunction.RandBetween(0, 255)
g = WorksheetFunction.RandBetween(0, 255)
b = WorksheetFunction.RandBetween(0, 255)
holder = Cells(FirstRow, 1).Value
For i = FirstRow To LastRow '<--| loop through rows index
myColor = RGB(r, g, b)
If Cells(i, 1).Value = holder Then
Cells(i, 1).EntireRow.Interior.Color = myColor
Else
holder = Cells(i, 1).Value
r = WorksheetFunction.RandBetween(0, 255)
g = WorksheetFunction.RandBetween(0, 255)
b = WorksheetFunction.RandBetween(0, 255)
Cells(i, 1).EntireRow.Interior.Color = RGB(r, g, b)
End If
Next i
you can begin with this code
Sub main()
Dim myCol As Long, i As Long
For i = 1 To 10 '<--| loop through rows index
With Cells(i, 1) '<--| reference cell at row i and column 1
Select Case .value
Case 100
myCol = vbBlue
Case 150
myCol = vbRed
Case Else
myCol = vbWhite
End Select
.EntireRow.Interior.Color = myCol
End With
Next i
End Sub
I suggest to do a random color when value changes loop:
Sub Color()
lastrow = ActiveSheet.UsedRange.Rows.Count
For i = 2 To lastrow
If Cells(i, 1).Value = Cells(i - 1, 1).Value Then
r = WorksheetFunction.RandBetween(0, 255)
g = WorksheetFunction.RandBetween(0, 255)
b = WorksheetFunction.RandBetween(0, 255)
Cells(i, 1).Interior.Color = RGB(r, g, b)
Else
Cells(i, 1).Interior.Color = RGB(r, g, b)
End If
Next i
End Sub
The result will look like this:
This is how you can check Cells A1 to A10 for value of 100 and if all cells contains 100, paint all rows from 1 to 10 with Blue color.
Sub ColorMeBlue()
Dim iStart, iEnd As Long
Dim i As Integer
Dim b As Boolean
iStart = 1: iEnd = 10
b = False
'~~> We will set b to true if all cells in A1:A10 conatins 100
For i = iStart To iEnd
If Cells(i, 1) = 100 Then
b = True
End If
Next
'~~> We will paint Blue if b is true
If b Then
Rows("1:10").Interior.Color = vbBlue
End If
End Sub
You can use same logic to for your next set rows.
The reason I didn't put the entire code is so that you can practice on your own.
Based on your reply to my comment, I assume you neither know the exact values in the first column nor how many different values there are.
To make my answer not too complicated, I assume further that the first column only contains non-negative numbers. If this is not the case, you just have to map the datatype in the column to that number range.
Under the ssumption above you can use the following code.
Public Sub SetRowColorBasedOnValue()
Dim firstColumn As Range
Set firstColumn = ActiveSheet.UsedRange.Columns(1)
Dim minValue As Double
Dim maxValue As Double
minValue = Application.Min(firstColumn)
maxValue = Application.Max(firstColumn)
Dim cell As Range
Dim shade As Double
For Each cell In firstColumn.Cells
If Not IsEmpty(cell) Then
shade = (CDbl(cell.Value2) - minValue) / (maxValue - minValue)
SetRowColorToShade cell, shade
End If
Next
End Sub
Private Sub SetRowColorToShade(ByVal cell As Range, ByVal shade As Double)
With cell.EntireRow.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent2
.TintAndShade = shade
.PatternTintAndShade = 0
End With
End Sub
Admittedly, the colours can be very similar. If you are using Excel 2013 or later you can use cell.EntireRow.Interior.Color = HSL(hue,saturation,chroma) instead of setting tint and shade to change the hue based on the value. This provides much more different colours.
My code mostly works but it's taking a while to debug so I am beginning to think my architecture may be flawed XD So how can I architect this better?
I have groups of data separated by a blank row. You can tell each group apart by the ID in column C in addition to the blank row. For each ID, I have various numbers in column B that I need to capture. Sometimes those numbers only start with 5, sometimes it starts with 7. I need to capture the 5 and the 7 separately.
With projWS
With .Range("C1:C6000")
Set f = .Find(cc, LookIn:=xlValues, lookat:=xlPart)
End With
If Not f Is Nothing Then 'first occurence found
counter = 0
i = f.Row
Do
acct = .Cells(i, 2)
If (Len(projWS.Cells(i, 3)) < 1 Or Left(acct, 1) = "7") And done = False Then
acctStart = f.Row
acctRows = i - acctStart
Set acctRng = .Range(.Cells(acctStart, 2), .Cells(i - 1, 5))
Set amountRng = .Range(.Cells(acctStart, 7), .Cells(i - 1, 8))
done = True 'set flag to show range has been filled
End If
counter = counter + 1 'increment counter
i = i + 1 'move to next row
Loop Until Len(.Cells(i, 3)) < 1 'keep looping until blank row
End If
If counter - 1 > acctRows Then 'how we determine if there's a "7"
flag = True 'so we set flag to true
Set depreRng = Range(.Cells(acctStart + acctRows, 2), .Cells(i - 1, 8))
dep = depreRng.Value2 'store range into array
End If
End With
After capture, I need to drop it into another worksheet. This worksheet already has a block of 7 built in. Hence this is the loop I am using to drop the range of 7. There is no built in block for the 5.
For r = 112 To 120
For k = 1 To UBound(dep())
If .Cells(r, 1).Value2 = Trim(dep(k, 1)) Then
Debug.Print .Cells(r, 1).Value2
.Cells(r, 6) = dep(k, 6)
.Cells(r, 7) = dep(k, 7)
Exit For
Else
.Cells(r, 6) = 0
.Cells(r, 7) = 0
End If
Next k
Next r
I have debugged several errors already. The current one is that depreRng is breaking because my math is bad. Instead of debugging each error as I stumble onto it, how can I architect this better?
Ok, my approach it's different. First i use a filter for find the range of rows with the index you are looking for and then loop inside this filtered rows for find the 5xx and the 7xx range. The code:
Sub Macro1()
Dim rng_5xx_start, rng_5xx_stop, rng_7xx_start, rng_7xx_stop As Integer
rng_5xx_start = 0
rng_5xx_stop = 0
rng_7xx_start = 0
rng_7xx_stop = 0
Dim range_5xx, range_7xx As String
'filter for the index you are looking for
'specify the maximum range, the field is the "offset" from the column B (the firts of the range), so for filter for column C you need to put 2, criteria...is the critera :)
ActiveSheet.Range("$B$1:$H$6000").AutoFilter Field:=2, Criteria1:="b"
'the filter returns only the rows with the specifyed index, now a for inside this rows for find the 5xx and the 7xx sub-ranges
For Each Row In ActiveSheet.Range("b1:b6000").SpecialCells(xlCellTypeVisible)
If Cells(Row.Row, 2).Value > 4999 And Cells(Row.Row, 2).Value < 6000 Then
'or any test for understnd if i'm in the 5xx range, if you prefer use the strings use something like left(cells(row.row,2).value,1) = "5"
If rng_5xx_start = 0 Then 'found the first row with a 5xx value
rng_5xx_start = Row.Row 'set the start of the range to this row
End If
If rng_5xx_stop < Row.Row Then 'the row where i am is in the 5xx range and is grater than the current end i noticed
rng_5xx_stop = Row.Row 'refresh the end of the range...at the end this will have the last number of row of the 5xx range
End If
End If
If Cells(Row.Row, 2).Value > 6999 And Cells(Row.Row, 2).Value < 8000 Then
'same as above but for 7xx range
If rng_7xx_start = 0 Then
rng_7xx_start = Row.Row
End If
If rng_7xx_stop < Row.Row Then
rng_7xx_stop = Row.Row
End If
End If
Next
If rng_5xx_start = 0 Then
'not found 5xx rows
range_5xx = "" 'or False, or what you prefer...
Else
range_5xx = "B" & rng_5xx_start & ":H" & rng_5xx_stop
End If
If rng_7xx_start = 0 Then
'not found 7xx rows
range_7xx = "" 'or False, or what you prefer...
Else
range_7xx = "B" & rng_7xx_start & ":H" & rng_7xx_stop
End If
End Sub
That's how i would imagine a macro for your job ;)
Edit 1:
I forgot that this will leave the sheet with the filter on...use activesheet.showalldata for show all the rows and not only the filtered ones
Edit 2:
The tests
If rng_5xx_stop < Row.Row Then
rng_5xx_stop = Row.Row
End If
and
If rng_7xx_stop < Row.Row Then
rng_7xx_stop = Row.Row
End If
are not necessary, it's enough do rng_5xx_stop = Row.Row and rng_7xx_stop = Row.Row and save the two IF statements
You are grouping cells based on the first number of the cell values in column B (I am assuming that they can never be letters). If that is the case, then you can create an array of 0 to 9 and store your ranges in there. Then go through the range.areas in order to get the groupings you're looking for (as highlighted in your screenshot).
To do this, something like this is all you need. I commented code to try to explain it more:
Sub tgr()
Dim wsData As Worksheet
Dim rColB As Range
Dim BCell As Range
Dim aRanges(0 To 9) As Range
Dim SubGroup As Range
Dim lRangeNum As Long
Dim i As Long
'Change to your actual worksheet
Set wsData = ActiveWorkbook.ActiveSheet
'Change to your actual column range, this is based off the sample data
Set rColB = wsData.Range("B1", wsData.Cells(wsData.Rows.Count, "B").End(xlUp))
'Loop through the column range
For Each BCell In rColB.Cells
'Make sure the cell is populated and the starting character is numeric
If Len(BCell.Value) > 0 And IsNumeric(Left(BCell.Value, 1)) Then
'Get the starting digit
lRangeNum = Val(Left(BCell.Value, 1))
'Check if any ranges have been assigned to that array index location
'If not, start a range at that array index
'If so, combine the ranges with Union
Select Case (aRanges(lRangeNum) Is Nothing)
Case True: Set aRanges(lRangeNum) = BCell
Case Else: Set aRanges(lRangeNum) = Union(aRanges(lRangeNum), BCell)
End Select
End If
Next BCell
'You can use any method you want to access the ranges, this just loops
'through the array indices and displays the range areas of each
For i = 0 To 9
If Not aRanges(i) Is Nothing Then
For Each SubGroup In aRanges(i).Areas
'Do what you want with it here
'This just selects the subgroup so you can see it found the groups properly
SubGroup.Select
MsgBox SubGroup.Address
Next SubGroup
End If
Next i
End Sub
I see you've allready rewritten your code, but I'd like to offer how I would do it and would like to know your thoughts about it. Would this be inefficient? I guess it could be because you have to read the first character in cells 4 times for every increment, but not shure if that is a big problem.
Dim start_row As Long
Dim end_row As Long
start_row = 1
end_row = 0
For i = 2 To Range("B" & Rows.Count).End(xlUp).Row
If Cells(i - 1, 2) = "" Then
start_row = i
ElseIf Left(Cells(i - 1, 2), 1) <> Left(Cells(i, 2), 1) Then
start_row = i
End If
If Cells(i + 1, 2) = "" Then
end_row = i
ElseIf Left(Cells(i + 1, 2), 1) <> Left(Cells(i, 2), 1) Then
end_row = i
End If
If end_row <> 0 Then
Call copy_range(start_row, end_row)
end_row = 0
End If
Next i
Another approach that lets you only read the character once could be
Dim start_row As Long
Dim end_row As Long
Dim char_above As String
Dim this_char As String
start_row = 1
end_row = 1
For i = 1 To Range("B" & Rows.Count).End(xlUp).Row
If Cells(i, 2) = "" Then
end_row = i - 1
if i <>1 then Call copy_range(start_row, end_row,char_above)
start_row = i + 1
Else
this_char = Left(Cells(i, 2), 1)
If this_char <> char_above Then
end_row = i - 1
if i<> 1 then Call copy_range(start_row, end_row,char_above)
start_row = i
End If
char_above = this_char
End If
Next i
Let me know your thoughts.
I have a macro that does the following:
SETUP:
Compares a ID# between the "April Count" and "Prg-Srv Data" and turns the ones that are in common to a green cell background.
Filters the common data (anything with a green cell background) and copies that to a new worksheet "Medicaid Report". Then clears the AutoFilter and and formats the worksheet to specified style.
Filters and removes any rows that contain the word "Duplicate".
Finally it compares the April Count to the Medicaid Report to see if anyone has been missed from the April Count list.
PROBLEM IS THIS:
When the macro is finished it is still "randomly" marking data in the April Count that is also in the Medicaid Report and I'm not sure what I have done wrong.
Also if there is a more efficient way to do this let me know, this macro takes a long time to run and I'm not sure if its just because it has to do 5,000+ records or if I coded inefficiently. Thanks
CODE:
Sub ComparePrgSrv()
'Get the last row
Dim Report As Worksheet
Dim Report2 As Worksheet
Dim Report3 As Worksheet
Dim i, j, k As Integer
Dim LastRow, LastRow2, LastRow3 As Integer
Dim UniqueVal As New Collection
Dim Val As String
Set Report = Excel.Worksheets("April Count")
Set Report2 = Excel.Worksheets("Prg-Srv Data")
Set Report3 = Excel.Worksheets("Medicaid Report")
LastRow = Report.UsedRange.Rows.count
LastRow2 = Report2.UsedRange.Rows.count
LastRow3 = Report3.UsedRange.Rows.count
Application.ScreenUpdating = False
'April Count to Program Services comparison.
For i = 2 To LastRow2
For j = 2 To LastRow
If Report2.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, 1).Value, Report2.Cells(i, 1).Value, vbTextCompare) > 0 Then
Report2.Cells(i, 1).Interior.Color = RGB(0, 102, 51) 'Dark green background
Report2.Cells(i, 1).Font.Color = RGB(0, 204, 102) 'Light green font color
Exit For
Else
Report2.Cells(i, 1).Interior.Color = xlNone 'Transparent background
Report2.Cells(i, 1).Font.Color = RGB(0, 0, 0) 'Black font color
End If
End If
Next j
Next i
'Filter Program Services to show correct data.
Report2.Range("$A$1:$M$" & LastRow2).AutoFilter Field:=1, Criteria1:=RGB(0, 102, 51), Operator:=xlFilterCellColor
'Copy filtered data to new worksheet.
Report2.Range("$A$1:$M$" & LastRow2).SpecialCells(xlCellTypeVisible).Copy Destination:=Worksheets("Medicaid Report").Range("A1")
'Clear filter selection on both sheets.
Report.AutoFilterMode = False
Report2.AutoFilterMode = False
'Format cell colors on Medicaid sheet.
Report3.UsedRange.Interior.Color = xlNone 'Transparent background
Report3.UsedRange.Font.Color = RGB(0, 0, 0) 'Black font color
Report3.Range("$A$1:$M$1").Interior.Color = RGB(31, 73, 125) 'Blue background
Report3.Range("$A$1:$M$1").Font.Color = RGB(255, 255, 255) 'White font color
'Filter and Delete Rows Containing "DUPLICATE"
With ActiveSheet
.AutoFilterMode = False
With Range("B1", Range("B" & Rows.count).End(xlUp))
.AutoFilter 1, "*DUPLICATE*"
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
End With
.AutoFilterMode = False
End With
'April Count to Medicaid Report comparison.
For i = 2 To LastRow
For j = 2 To LastRow3
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, Report3.Cells(j, 1).Value, Report.Cells(i, 1).Value, vbTextCompare) > 0 Then
Report.Cells(i, 1).Interior.Color = xlNone 'Transparent 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
End Sub
Workbook Setup:
First off, what do you mean by
"When the macro is finished "
For the effectiveness part:
You should remove the If Report2.Cells(i, 1).Value <> "" Then as it is already taken in account with the InStr. If cell is empty InStr will evaluate as 0; that should speed up a bit.
Secondly, you should get the last row of data using this:
LastRow = Report.Range("a" & Report.Rows.Count).End(xlUp).Row
LastRow2 = Report2.Range("a" & Report2.Rows.Count).End(xlUp).Row
LastRow3 = Report3.Range("a" & Report3.Rows.Count).End(xlUp).Row
"a" being the column containing the data to be checked. This will give you exactly the last non-empty row of the aimed column instead of the total used range of the entire sheet.
Also, in VBA, when you declare variables on one line, this:
Dim i, j, k As Integer
will only declare "k" as an Integer but "i" and "j" will be Variant
You should write it as:
Dim i As Integer, j As Integer, k As Integer. Same remark for Dim LastRow, LastRow2, LastRow3 As Integer
And don't forget to enable the Application.ScreenUpdating before exiting the Sub.
Im working on a little script (below). The script iterates through rows on a data set and places either a 1 or 0 in a cell based on some contingencies of 2 select case statements. It works perfect, but I want to know if there's a way to group the range of cells together that are getting a 0 placed within them.
Sub compVal()
Dim WB As Workbook 'an object of type workbook
Dim WS1 As Worksheet ' objects of type worksheet
Set WB = ActiveWorkbook ' reference WB to the current Workbook
Set WS1 = Worksheets("Sheet1") 'Reference to Sheet 1 of the current workbook
'loop through sheet1's rows
Dim i As Integer
For i = 2 To WS1.UsedRange.Rows.Count
Select Case WS1.Cells(i, 1).Value 'first cell from row i
Case "Target"
Select Case WS1.Cells(i, 2).Value
Case 1
WS1.Cells(i, 3).Value = 1
WS1.Cells(i, 4).Value = 0
WS1.Cells(i, 5).Value = 0
WS1.Cells(i, 6).Value = 0
Case 2
WS1.Cells(i, 3).Value = 0
WS1.Cells(i, 4).Value = 0
WS1.Cells(i, 5).Value = 1
WS1.Cells(i, 6).Value = 0
End Select
Case "NonTarget"
Select Case WS1.Cells(i, 2).Value
Case 1
WS1.Cells(i, 3).Value = 0
WS1.Cells(i, 4).Value = 1
WS1.Cells(i, 5).Value = 0
WS1.Cells(i, 6).Value = 0
Case 2
WS1.Cells(i, 3).Value = 0
WS1.Cells(i, 4).Value = 0
WS1.Cells(i, 5).Value = 0
WS1.Cells(i, 6).Value = 1
End Select
End Select
Next i
End Sub
This is a great example of code re-use:
Sub compVal()
Dim WB As Workbook 'an object of type workbook
Dim WS1 As Worksheet ' objects of type worksheet
Set WB = ActiveWorkbook ' reference WB to the current Workbook
Set WS1 = Worksheets("Sheet1") 'Reference to Sheet 1 of the current workbook
'loop through sheet1's rows
Dim i As Long ' USE LONG FOR CELL REFERENCES, THERE ARE A LOT OF ROWS POSSIBLE : )
For i = 2 To WS1.UsedRange.Rows.Count
Select Case WS1.Cells(i, 1).Value 'first cell from row i
Case "Target"
Select Case WS1.Cells(i, 2).Value
Case 1
AddColumns WS1, i, 1, 0, 0, 0
Case 2
AddColumns WS1, i, 0, 0, 1, 0
End Select
Case "NonTarget"
Select Case WS1.Cells(i, 2).Value
Case 1
AddColumns WS1, i, 0, 1, 0, 0
Case 2
AddColumns WS1, i, 0, 0, 0, 1
End Select
End Select
Next i
End Sub
Sub AddColumns(WS As Worksheet, i As Long, c As Variant, d As Variant, e As Variant, f As Variant)
WS.Cells(i, 3).Resize(1, 4).Value = Array(c, d, e, f)
End Sub
There are other efficiencies that could be introduced, such as replacing the four arguments c,d,e and f with a single integer where
0 = 0,0,0,0
1 = 1,0,0,0
2 = 0,1,0,0
...
15 = 1,1,1,1
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