Thank you for see this question.
Due to my bad communication, my previous posts could not tell what my purpose was.
My goal is, to split this range
Set rng = Application.Intersect(Target, Me.Range("M31:AM53"))
to different ranges, I created calendar style schedule sheets, so it requires
at least non adjacent 42 ranges.
Below code shows my image of that 42 different ranges(insert "1" is its range)
I want change cell interior color dynamically.
Sub WriteNumber_v4()
Dim rng As Range
Dim i, j As Integer
For i = 1 To 6
For j = 1 To 7
Set rng = Range("M31:O33").Offset((i - 1) * 4, (j - 1) * 4)
rng.Value = 1
Next j
Next i
End Sub
Thankfully, many people answered me. Those helped me a lot.
I hope you would help and enlighten me again.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim trlRed As Long, sPhoneYellow As Long, adrBlue As Long, iosGrey As Long, cmnPurple As Long
Dim rng As Range, cell As Range
trlRed = RGB(230, 37, 30)
aaaPhoneYellow = RGB(255, 234, 0)
adrGreen = RGB(126, 199, 216)
iosGrey = RGB(162, 170, 173)
cmnPurple = RGB(165, 154, 202)
'firstLvValFor = Array("Trial, "Basic", "Novice", "Intermediate", "Advanced")
secondLvValFor = Array("aaaPhone", "Android", "iPhone", "Common")
thirdLvValFor_01 = Array("Beginner", "Text", "PhoneCall", "mail", "camera",)
thirLvValFor_02 = Array("Security", "SomeSnsApps")
Set rng = Application.Intersect(Target, Me.Range("M31:AM53"))
If Not rng Is Nothing Then 'only loop though any cells in M31:AM53
For Each cell In rng.Cells
If cell.Value = "Session" And cell.Offset(0, -2).Value = "Trial" Then
cell.Offset(0, -2).Resize(1, 3).Interior.Color = trlRed
ElseIf IsError(Application.Match(cell.Value, thirdLvValFor_01, 0)) = False And cell.Offset(0, -1).Value = "aaaPhone" And cell.Offset(0, -2).Value <> "TRIAL" Then
cell.Offset(0, -2).Resize(1, 3).Interior.Color = aaaPhoneYellow
ElseIf cell.Value = "aaaPhone" And IsError(Application.Match(cell.Offset(0, 1).Value, thirdLvValFor_01, 0)) = False And cell.Offset(0, -1).Value <> "TRIAL" Then
cell.Offset(0, -1).Resize(1, 3).Interior.Color = aaaPhoneYellow
Else
cell.Interior.ColorIndex = xlColorIndexNone
End If
Next cell
End If
End Sub
Related
It's my first time doing VBA Macro and I'm having a hard time understanding the problem.
I'm trying to filter and color cells with specific values but when I try running the code it says 'Type mismatch'.
Dim count, i As Long
Dim ws As Worksheet
Dim count, i As Long
Dim ws As Worksheet
Set ws = Sheets("Sheet1")
count = ws.Cells(Rows.count, "E").End(xlUp).Row
i = 2
Do While i <= count
If Cells(i, 5).Value = "#N/A" _
Or Cells(i, 5).Value = "#Ref" _
Or Cells(i, 5).Value = "Null" _
Or Cells(i, 5).Value = "" _
Or Cells(i, 5).Value = "#DIV/0!" _
Or Cells(i, 5).Value = "" _
Or Cells(i, 5).Value Like "*-*" Then
Cells(i, 5).Interior.Color = RGB(38, 201, 218)
End If
i = i + 1
Loop
ws.Range("E1").AutoFilter Field:=5, Criteria1:=RGB(38, 201, 218), Operator:=xlFilterCellColor
And when I click the debug it highlights the If statements. Is there a way to solve this or is there a better way to filter these values while highlighting them in VBA?
Not really an answer, more of a expanded comment.
If IsError(Cells(i, 5)) Then
Cells(i, 5).Interior.Color = RGB(0, 0, 255)
ElseIf Cells(i, 5).Value = "" Then
Cells(i, 5).Interior.Color = RGB(0, 0, 255)
Else
Cells(i, 5).Interior.Color = xlNone
End If
Also, this to sift the errors https://learn.microsoft.com/en-us/office/vba/excel/concepts/cells-and-ranges/cell-error-values
First problem: If your cell contain an error, it doesn't contain the string "#N/A" or "#Ref", it contains a special value. What you see is only a visual representation of that error. If you want to check for an error within Excel, you should use the function IsError. That would lead to (wait, don't use that!):
If isError(Cells(i, 5).Value)
Or Cells(i, 5).Value = "Null" _
Or Cells(i, 5).Value = "" _
Or Cells(i, 5).Value Like "*-*" Then
Second problem: In VBA, there is no optimization for a conditional statement, VBA will always evaluate all parts. Your If-statement contains several conditions, combined with Or. While other programming languages quit evaluating when one condition makes the whole expression true, VBA will continue to evaluate all conditions.
Now if you have an error in a cell and you would use the code above, you will still get a type mismatch error: You cannot compare an error with a string. The condition isError(Cells(i, 5).Value) will get True, but VBA will continue to compare the cell content with strings and that gives you the mismatch. You need a way to split your If-statement.
Some more remarks: You are assigning the worksheet you want to work with to variable ws, but you are not using it. You will need to qualify every single usage of Cells (write ws.Cells(i, 5), else VBA will assume you are working with the Active Sheet, and that may or may not be Sheet1. Usually, this is done with a With-statement (note all the leading dots).
Your declaration statement is flawed (a common mistake in VBA), you will need to specify the type for every variable. In your case, Count will be of type Variant, not Long. No problem here, but in other cases it is, so make it a habit to declare all variables correctly.
You should use a For-Loop rather than a Do While.
Dim count As Long, i As Long
With ws
count = .Cells(.Rows.count, "E").End(xlUp).Row
For i = 2 to count
Dim markCell as boolean
If isError(.Cells(i, 5).Value) Then
markCell = True
ElseIf .Cells(i, 5) = "Null" _
Or .Cells(i, 5).Value = "" _
Or .Cells(i, 5).Value Like "*-*" Then
markCell = True
Else
markCell = False
End If
If markCell Then
.Cells(i, 5).Interior.Color = RGB(38, 201, 218)
End If
Next i
End With
If you want to check for specific errors you first need to check if there are errors with IsError. You cannot check for an error and a value in one condition:
Do While i <= count
Dim Condition As Boolean
Condition = False ' initialize when in a loop!
If IsError(Cells(i, 5).Value) Then
If Cells(i, 5).Value = CVErr(xlErrNA) _
Or Cells(i, 5).Value = CVErr(xlErrRef) _
Or Cells(i, 5).Value = CVErr(xlErrNull) _
Or Cells(i, 5).Value = CVErr(xlErrDiv0) Then
Condition = True
End If
ElseIf Cells(i, 5).Value = "" Or Cells(i, 5).Value Like "*-*" Then
Condition = True
End If
If Condition = True Then
Cells(i, 5).Interior.Color = RGB(38, 201, 218)
End If
Loop
Filter By Color
Sub FilterByColor()
Const wsName As String = "Sheet1"
Const Col As String = "E"
Dim FilterColor As Long: FilterColor = RGB(38, 201, 218)
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
If ws.FilterMode Then ws.ShowAllData ' remove any filters
Dim lRow As Long: lRow = ws.Cells(ws.Rows.count, Col).End(xlUp).Row
Dim rgData As Range ' data range; no header
Set rgData = ws.Range(ws.Cells(2, Col), ws.Cells(lRow, Col))
rgData.Interior.Color = xlNone ' remove all colors
Dim rgColor As Range ' the combined range to be colored
Dim DataCell As Range ' each cell of the data range
Dim cString As String
Dim DoColor As Boolean
For Each DataCell In rgData.Cells
If IsError(DataCell) Then ' error value
DoColor = True
Else
cString = CStr(DataCell.Value)
If Len(cString) = 0 Then ' blank
DoColor = True
Else
If InStr(1, cString, "-") > 0 Then ' contains a minus ('-')
DoColor = True
End If
End If
End If
If DoColor Then
If rgColor Is Nothing Then ' combine cells into a range
Set rgColor = DataCell
Else
Set rgColor = Union(rgColor, DataCell)
End If
DoColor = False ' don't forget to reset
End If
Next DataCell
If rgColor Is Nothing Then Exit Sub
rgColor.Interior.Color = FilterColor ' apply color in one go
Dim rgTable As Range ' table range; header included
Set rgTable = ws.Range(ws.Cells(1, Col), ws.Cells(lRow, Col))
rgTable.AutoFilter 1, FilterColor, xlFilterCellColor
' To delete the rows, you could continue with e.g.:
' rgData.SpecialCells(xlCellTypeVisible).EntireRow.Delete
' ws.AutoFilterMode = False ' remove 'AutoFilter'
End Sub
A run-time error occurs in the OFFSET portion of a process that finds cells with the same data in different sheets and flags the corresponding dates for those cells
I've put the offset value of the Search Cell in the String and also put it in the Range type.
Option Explicit
Option Compare Text
Sub compare()
Dim SearchRange, SearchCell, Dtt2, StdRange, StdCell As Range
Dim Dtlist As Range
Dim v1, DtCell, Dtv, Dtt, CurrDtv, FirstAddress, Standard As String
Dim r As Long
Dim maxr As Integer
Dim Dt As Date
'Dt = Worksheets("EOB").Range("H3").Value
'Dtv = DateValue(Dt)
Set Dtlist = Worksheets("2019").UsedRange.Columns("A")
Set StdRange = Worksheets("EOB").Columns("C")
Set SearchRange = Worksheets("2019").Columns("B")
maxr = Sheet2.UsedRange.Rows.Count
MsgBox "Sheet2에 있는 " & maxr & "개의 Data가 비교되었습니다"
With Sheet3.UsedRange
For r = 1 To maxr
Standard = Sheet2.Cells(r, 3).Address
Set StdCell = Worksheets("EOB").Range(Standard)
v1 = Sheet2.Cells(r, 3).Value
Set SearchCell = SearchRange.Find(v1, , xlValues, xlWhole)
DtCell = Sheet3.Cells(r, 1).Value
If Not SearchCell Is Nothing Then
FirstAddress = SearchCell.Address
Do
If SearchCell.Offset(, -1).Value <= Date And SearchCell.Offset(, -1).Value > DateAdd("m", -6, Now) Then
StdCell.Offset(, 1) = 1
ElseIf SearchCell.Offset(, -1).Value <= DateAdd("m", -6, Now) And SearchCell.Offset(, -1).Value > DateAdd("yyyy", -1, Now) Then
StdCell.Offset(, 1) = 2
Else: StdCell.Offset(, 1) = 3
End If
Set SearchCell = .FindNext(SearchCell)
Loop While Not SearchCell Is Nothing And SearchCell.Address <> FirstAddress
ElseIf SearchCell Is Nothing Then
StdCell.Interior.Color = RGB(255, 180, 180)
End If
Next
Worksheets("TEST").Range("A2") = Dtv
End With
End Sub
If SearchCell.Offset(, -1).Value <= Date And SearchCell.Offset(, -1).Value > DateAdd("m", -6, Now) Then
----->
Say 1004 runtime errors occur here
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
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