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.
Related
I am encountering a bug in VBA. As I am just a few weeks in, the code itself probably lacks a lot of best practices.
But besides that, in this specific case I get an Overflow error on the following line
dateDifference = DateDiff("d", currentDate, olderDate, vbMonday) in the section
'========================
'make cell BLUE
'========================
The full code is listed below. Does anybody have an idea, what is causing this issue? As a greenhorn my guess is, this has to do with constantly reassigning 3 variables in the loop?
Thanks a lot in advance.
Sub HrReporting_Step07_ApplyCellColouring()
ThisWorkbook.Activate
'========================
'Variables for looping
'========================
'declarations
Dim rowCount As Integer
Dim i As Integer
Dim srcColourColumnIntRed1 As Integer
Dim srcColourColumnIntRed2 As Integer
Dim srcColourColumnIntYellow As Integer
Dim srcColourColumnIntGreen As Integer
Dim srcColourColumnIntBlue1 As Integer
Dim srcColourColumnIntBlue2 As Integer
'variable declaration specifically for date calculations that are needed for colouring cells YELLOW or BLUE
Dim olderDate As Date
Dim currentDate As Date
Dim dateDifference As Integer
'assignments
srcColourColumnIntRed1 = Range("Table1[Availability Status]").Column
srcColourColumnIntRed2 = Range("Table1[Sum of Current Calendar % Allocated]").Column
srcColourColumnIntYellow = Range("Table1[Coming Available Category]").Column
srcColourColumnIntGreen = Range("Table1[CW-1]").Column
srcColourColumnIntBlue1 = Range("Table1[Current Calendar]").Column
srcColourColumnIntBlue2 = Range("Table1[Current Calendar End Date]").Column
rowCount = Range("Table1[Coming Available Category]").Count + 1
'========================
'make cell RED
'========================
For i = 2 To rowCount
'based on following conditions
' 1. Column "Sum of Current Calendar % Allocated" is lower or equal to 60 %
' 2. Column "Availability Status" = Now Available
If Cells(i, srcColourColumnIntRed1).Value = "Now Available" _
Or Cells(i, srcColourColumnIntRed2).Value <= 60 _
Then Cells(i, 1).Interior.Color = RGB(255, 0, 0)
Next i
'========================
'make cell YELLOW
'========================
For i = 2 To rowCount
'based on following condition
' 1. Column "Coming Available Category" = Available in the next 2 weeks
If Cells(i, srcColourColumnIntYellow).Value = "Resource First Available Day 1-7 Days" _
Or Cells(i, srcColourColumnIntYellow).Value = "Resource First Available Day 8-14 Days" _
Then Cells(i, 1).Interior.Color = RGB(255, 255, 0)
Next i
'========================
'make cell BLUE
'========================
For i = 2 To rowCount
'based on following conditions
' 1. Column "Current Calendar" unequal to "Booked To A Project"
' 2. Column "Current Calendar" unequal to empty
' 3. Column "Current Calendar End Date" < to 42 days AND > 12 days
olderDate = Cells(i, Range("Table1[Current Calendar End Date]").Column)
currentDate = Date
dateDifference = DateDiff("d", currentDate, olderDate, vbMonday)
If (Cells(i, srcColourColumnIntBlue1).Value <> "Booked To A Project" _
And Cells(i, srcColourColumnIntBlue1).Value <> "") _
Or (dateDifference <= 42 And dateDifference > 14) _
Then Cells(i, 1).Interior.Color = RGB(0, 0, 255)
Next i
'========================
'make cell GREEN
'========================
For i = 2 To rowCount
'based on following condition
' 1. Name does not exist in previous weeks' sheet, identified by VLOOKUP being #N/A
If WorksheetFunction.IsNA(Cells(i, srcColourColumnIntGreen)) _
Then Cells(i, 1).Interior.Color = RGB(0, 255, 0)
Next i
End Sub
It turned out that the comments from BigBen and Ron Rosenfeld solved my issue. I needed to simply declare dateDifference as Long, and the Overflow error was gone. Thank you.
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.
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 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.
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