The aim is to search in column A for the word "XXX". When the word is found in that column, the next cell should match the word "C".If it doesn't, carry on with the search for "XXX" in the next row, etc. The issue in my code is that it marks all "C"s. In other words, there is no conditional search where XXX=C.
For Each cell In ws.Range("A1:A20").SpecialCells(xlCellTypeConstants)
Select Case cell.Value2
Case "XXX"
col = RGB(202, 225, 255)
Case Else
col = 0
End Select
If col > 0 Then
wb.Activate
cell.Interior.Color = col
For Each cell2 In cell.Offset(, 2).Resize(1).SpecialCells (xlCellTypeConstants)
res = Switch(cell2.Value = "C", vbGreen)
If Not IsNull(res) Then Intersect(Range("B:B, J:J, L:L, N:N, Q:Q"), Rows(cell2.Row)).Interior.Color = CLng(res) '
Next
End If
Next
Edited: See Below
Slightly unsure what you're asking but I think solution is below.
I have used much simpler code but it should be adequate.
For xJ = 1 to 200
If Range("A" & xJ).Value = "XXX" then
Range("A" & xJ).Interior.Color = RGB(202, 225, 255)
If Range("B" & xJ).Value = "C" Then
Range("B" & xJ).Interior.Color = RGB(57, 225, 20)
End If
End if
Next xJ
Related
I am trying to create a For and Do while loop in VBA. I want that when the value 'X' is entered in column A and if column W is equal to "T", all the rows below (column A) should be checked "X" until the next value "T" in column W.
My script does not work, only the row below is filled with "X" and the file closes (bug!)
Here is the complete code
Sub Chaine()
For Each Cell In Range("A2:A3558")
If UCase(Cell.Value) = "X" And Cells(Target.Row, 23) = "T" Then
Do While Cell.Offset(0, 23) <> "T"
Cell.Offset(1, 0).Value = "X"
Loop
End If
Next Cell
End Sub
Try this:
Sub Chaine()
Dim c As Range, vW, flag As Boolean
For Each c In ActiveSheet.Range("A2:A3558").Cells
vW = UCase(c.EntireRow.Columns("W").value)
If UCase(c.value) = "X" And vW = "T" Then
flag = True 'insert "X" beginning on next row...
Else
If vW = "T" Then flag = False 'stop adding "X"
If flag Then c.value = "X"
End If
Next c
End Sub
Your Do While loop has to be problem as it doesn't change and will continue to check the same thing. It's unclear what you want to happen, but consider something like this as it moves to the right until you've exceeded the usedrange.
Sub Chaine()
Dim cell As Range
For Each cell In Range("A2:A3558").Cells
If UCase(cell.Value) = "X" And Cells(Target.Row, 23) = "T" Then
Do While cell.Offset(0, 23) <> "T"
Set cell = cell.Offset(0, 1)
'not sure what this is supposed to do...?
'cell.Offset(1, 0).Value = "X"
If cell.Column > cell.Worksheet.UsedRange.Cells(1, cell.Worksheet.UsedRange.Columns.Count).Column Then
MsgBox "This has gone too far left..."
Stop
End If
Loop
End If
Next cell
End Sub
I just went off your description in the question. Your code is not doing what you want and it's not really how you would do this in my opinion. I figured I would put an answer that does what you ask but, keep it simple.
I'm guessing Target in the code refers to an event.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo SomethingBadHappened
'Checks if you are in the A column from the target cell that
'was changed and checks if only X was typed.
If (Target.Column = 1 And UCase(Target) = "X") Then
Dim colToCheck_Index As Integer
colToCheck_Index = 23 'W Column
Dim colToCheck_Value As String
Dim curRow_Index As Integer
curRow_Index = Target.Cells.Row
'Checks if the column we are checking has only a T as the value.
If (UCase(ActiveSheet.Cells(curRow_Index, colToCheck_Index).Value) = "T") Then
Application.EnableEvents = False
Do
'Set the proper cell to X
Range("A" & curRow_Index).Value = "X"
curRow_Index = curRow_Index + 1
'Set the checking value to the next row and check it in the
'while loop if it doesn't equal only T
colToCheck_Value = ActiveSheet.Cells(curRow_Index, colToCheck_Index)
'Set the last row to X on the A column.
Loop While UCase(colToCheck_Value) <> "T"
Range("A" & curRow_Index).Value = "X"
Application.EnableEvents = True
End If
Exit Sub
SomethingBadHappened:
Application.EnableEvents = True
End If
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 am new to vba and I am attempting to create a module that takes the value in column C ( which should say "In Progress")and makes it "neutral" colored if the value within the same row on column E is less than 0.5(or 50%) but I have not had any luck. I have a counter variable made to keep track of the row I'm on. Any advice would be helpful and if you could recommend me to a good source for learning vba I would really appreciate it.
If Range("C1") = "Status" Then
Range("C1").Select
Do Until ActiveCell.Value = ""
If ActiveCell.Offset(1, 0).Value = "In Progress" Then
If Range("E" & counter).Value < 0.5 Then
ActiveCell.Offset(1, 0).Style = "Neutral"
End If
End If
ActiveCell.Offset(1, 0).Select
Columns("C").ColumnWidth = 13
counter = counter + 1
Loop
End If
End Sub
Untested:
Dim c As Range, sht As WorkSheet
Set sht = ActiveSheet
If sht.Range("C1").Value = "Status" Then
Set c = sht.Range("C2")
Do Until Len(c.Value) = 0
If c.Value = "In Progress" Then
If c.EntireRow.Cells(1, "E").Value < 0.5 Then
c.Style = "Neutral"
Else
c.Style = "Normal"
End If
End If
Set c = c.Offset(1, 0)
Loop
sht.Columns("C").ColumnWidth = 13
End If
As far as I understood your problem and this fits for you, you could try this. The following code searches for value "In Progress" in the entire column A, and if this value is found and the same row cell in column C is less than 0.5, then sets the color of the cell in column A to "no fill".
Sub searchValue()
Dim cell As Range
For Each cell In Worksheets(1).Columns(1).Cells
If cell = "In Progress" Then
If cell.Offset(0, 2) < 0.5 Then cell.Interior.ColorIndex = 0
End If
Next cell
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