Comparison Macro - excel

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.

Related

Highlight cells if appearing in another sheet with a macro

I would like to create a simple button with a macro.
I have three Sheets in my excel file:
"VLS", "DTMS"and "Results"
I would like a macro which highlights the cells in column A in 'Results' if they appear in column A in VLS or DTMS respectively.
Is it possible to highlight the cells appearing in VLS with green and DTMS with blue?
Does this code help you?
Sub test()
Dim LastRowSheet1 As Integer
Dim LastRowSheet2 As Integer
Dim LastRowSheet3 As Integer
LastRowSheet1 = Sheets("Results").Cells(1, 1).End(xlDown).Row
LastRowSheet2 = Sheets("VLS").Cells(1, 1).End(xlDown).Row
LastRowSheet3 = Sheets("DTMS").Cells(1, 1).End(xlDown).Row
Dim Found As Boolean
Found = False
For i = 1 To LastRowSheet1
For j = 1 To LastRowSheet2
If Sheets("Results").Cells(i, 1).Value = Sheets("VLS").Cells(j, 1).Value Then
Sheets("Results").Cells(i, 1).Interior.Color = RGB(0, 255, 0)
'''Value found in sheet VLS => GREEN'''
Found = True
Exit For
End If
Next j
For k = 1 To LastRowSheet3
If Sheets("Results").Cells(i, 1).Value = Sheets("DTMS").Cells(k, 1).Value Then
If Found = True Then
Sheets("Results").Cells(i, 1).Interior.Color = RGB(255, 0, 0)
'''Value found in sheet VLS and DTMS => RED'''
Else
Sheets("Results").Cells(i, 1).Interior.Color = RGB(0, 0, 255)
'''Value found in sheet DTMS => BLUE'''
End If
Exit For
End If
Next k
Found = False
Next i
End Sub
It loops through your sheet "Results" column A and check all the values of the two others sheets : first with the sheet VLS then with DTMS.
As soon as the same value is detected in VLS, it changes the color to GREEN. Then if the value is also in DTMS, it changes the color to RED or if it's only in DTMS it changes it in BLUE.
If it works, you can create a button and then affect this macro to it.

How to colour cell in column C automatically in a colour when the sum of the values of cells next to it in column A and B is 5? (Excel-VBA)

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

Comparing two columns with ID

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

Excel VBA delete duplicates keep positioning

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

VBA macro to compare two columns and color highlight cell differences

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

Resources