The below code works and changes the offset cells when north is entered, i would like to also have it change if its south, west or east but i can seem to find a way to add this.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("A7:A26")
Set rng = Range("A7:A26")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
For Each cell In rng.Cells
If cell.Value = "North" Then
cell.Offset(0, 1).Interior.Color = RGB(0, 255, 0)
cell.Offset(0, 2).Interior.Color = RGB(0, 255, 0)
cell.Offset(0, 3).Interior.Color = RGB(0, 255, 0)
End If
Next
End If
End Sub
Try using a Select Case instead of If statements for this.
For Each cell In Rng.Cells
Select Case cell.Value
Case "North"
Range(cell.Offset(0, 1), cell.Offset(0, 3)).Interior.Color = RGB(0, 255, 0)
Case "South"
Range(cell.Offset(0, 1), cell.Offset(0, 3)).Interior.Color = RGB(0, 155, 0)
Case "East"
Range(cell.Offset(0, 1), cell.Offset(0, 3)).Interior.Color = RGB(0, 55, 0)
Case "West"
Range(cell.Offset(0, 1), cell.Offset(0, 3)).Interior.Color = RGB(0, 0, 0)
End Select
Next
Give this a shot. Just update the color assignments as needed:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("A7:A26")
Set rng = Range("A7:A26")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
For Each cell In rng.Cells
If cell.Value = "North" Then
cell.Offset(0, 1).Interior.Color = RGB(0, 255, 0)
cell.Offset(0, 2).Interior.Color = RGB(0, 255, 0)
cell.Offset(0, 3).Interior.Color = RGB(0, 255, 0)
ElseIf cell.Value = "South" Then
cell.Offset(0, 1).Interior.Color = RGB(255, 0, 0)
cell.Offset(0, 2).Interior.Color = RGB(255, 0, 0)
cell.Offset(0, 3).Interior.Color = RGB(255, 0, 0)
ElseIf cell.Value = "East" Then
cell.Offset(0, 1).Interior.Color = RGB(0, 0, 255)
cell.Offset(0, 2).Interior.Color = RGB(0, 0, 255)
cell.Offset(0, 3).Interior.Color = RGB(0, 0, 255)
ElseIf cell.Value = "West" Then
cell.Offset(0, 1).Interior.Color = RGB(0, 255, 255)
cell.Offset(0, 2).Interior.Color = RGB(0, 255, 255)
cell.Offset(0, 3).Interior.Color = RGB(0, 255, 255)
End If
Next
End If
End Sub
Consider:
If cell.Value = "North" Or cell.Value = "South" Then
cell.Offset(0, 1).Interior.Color = RGB(0, 255, 0)
cell.Offset(0, 2).Interior.Color = RGB(0, 255, 0)
cell.Offset(0, 3).Interior.Color = RGB(0, 255, 0)
End If
or:
If cell.Value = "North" Then
cell.Offset(0, 1).Interior.Color = RGB(0, 255, 0)
cell.Offset(0, 2).Interior.Color = RGB(0, 255, 0)
cell.Offset(0, 3).Interior.Color = RGB(0, 255, 0)
ElseIf cell.Value = "South"
cell.Offset(0, 1).Interior.Color = RGB(0, 0, 255)
cell.Offset(0, 2).Interior.Color = RGB(0, 0, 255)
cell.Offset(0, 3).Interior.Color = RGB(0, 0, 255)
End If
Related
So I have the following code that I use for comparing values in two columns, but it is based on if the value is in either column, NOT a side by side comparison.
Is there a way to easily modify the code to do a side by side comparison? (meaning I want it to check if cell A1=B1, A2=B2, A3=B3, etc)
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.ActiveSheet
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
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
I have got a list of percentage values that are really small (0.000% format), this represents the error percentage of routers. i want to format the cell color depending on the amount on the cell. if the amount is more than 0.050% it should be Red, if it is more than 0.005% is amber, everything else is green
here is the code that i have written:
With .Cells(i, 8)
If .NumberFormat <> "0.000%" Then
.NumberFormat = "0.000%"
If .Value2 <> vbNullString And IsNumeric(.Value2) Then .Value = .Value / 100
If .Value2 = vbNullString Then
.Value = "---"
.HorizontalAlignment = xlRight
End If
Else
.Value = 0
End If
If .Value > 0.05 Then
.Interior.Color = RGB(237, 67, 55) '<-- Red color
.Font.Color = vbWhite
ElseIf .Value > 0.005 Then
.Interior.Color = RGB(255, 190, 0) '<-- Amber Colour
.Font.Color = vbWhite
Else
.Interior.Color = RGB(50, 205, 50) '<-- Green color
.Font.Color = vbWhite
End If
End With
but the colour format is not accurate, here is the list of some of the results:
0.034% <---green
0.845% <---amber
0.007% <---green
0.005% <---green
0.094% <---green
it should not be like that as the cell that contains 0.845% and is amber should be bright red!
The value stored is not a percentage. It is the decimal equivalent, meaning you must shift the decimal point two places to the left. So to compare 0.05% you must use 0.0005.
This should clean up the code for you to make it a bit faster too:
Sub Test()
Dim Cel As Range, Rng As Range
Set Rng = Range("H1:H" & Range("H1048576").End(xlUp).Row).SpecialCells(xlCellTypeConstants)
For Each Cel In Rng
If Trim(Cel.Value) = "" Then Cel.Value = "---": Cel.HorizontalAlignment = xlRight
If IsNumeric(Cel.Value) Then
Cel.Value = Cel.Value / 100
If Cel.Value > 0.0005 Then
Cel.Interior.Color = RGB(237, 67, 55): Cel.Font.Color = vbWhite
ElseIf Cel.Value > 0.00005 Then
Cel.Interior.Color = RGB(255, 190, 0): Cel.Font.Color = vbWhite
Else: Cel.Interior.Color = RGB(50, 205, 50): Cel.Font.Color = vbWhite
End If
End If
Next
With Range("H1:H" & Range("H1048576").End(xlUp).Row).SpecialCells(xlCellTypeBlanks)
.Value = "---"
.HorizontalAlignment = xlRight
End With
End Sub
I'm just after realizing Paul corrected your question....
I have this VBA code that I am using to compare two columns in my Excel spreadsheet, column B to column A. It then "highlights" the ones that are missing from column A but in column B.
What I can't figure out is how to reverse the procedure to search column B and highlight the ones in column A that are different.
Original Code:
For i = 2 To LastRow
For j = 2 To LastRow
If Report.Cells(i, 2).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, Report.Cells(i, 2).Value, vbTextCompare) > 0 Then
Report.Cells(i, 2).Interior.Color = xlNone 'Transparent 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
I have tried renaming the letters and switching the column values and got close but realized that it was using the values from the original search and just highlighting the corresponding cells in column A.
To answer your question:
For j = 2 To LastRow
For i = 2 To LastRow
If Report.Cells(j, 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(i, 2).Value, Report.Cells(j, 1).Value, vbTextCompare) > 0 Then
Report.Cells(j, 1).Interior.Color = xlNone 'Transparent background
Report.Cells(j, 1).Font.Color = RGB(0, 0, 0) 'Black font color
Exit For
Else
Report.Cells(j, 1).Interior.Color = RGB(156, 0, 6) 'Dark red background
Report.Cells(j, 1).Font.Color = RGB(255, 199, 206) 'Light red font color
End If
End If
Next i
Next j
If you wanted to used conditional formatting which makes the color changes live you can replace both loop with:
With Report.Range("A2:A" & LastRow).FormatConditions
.Delete
With .Add(Type:=xlExpression, Formula1:="=And(iserror(Vlookup(A2,B:B,1,False)),A2<>"""")")
.Font.Color = RGB(255, 199, 206)
.Interior.Color = RGB(156, 0, 6)
End With
End With
With Report.Range("B2:B" & LastRow).FormatConditions
.Delete
With .Add(Type:=xlExpression, Formula1:="=And(iserror(Vlookup(B2,A:A,1,False)),B2<>"""")")
.Font.Color = RGB(255, 199, 206)
.Interior.Color = RGB(156, 0, 6)
End With
End With
Edit the issue was that the data in Column A had an extra space at the end thus making the instr to return false.
For j = 2 To LastRow
Report.Cells(j, 1).Value = Trim(Report.Cells(j, 1).Value)
For i = 2 To LastRow
Report.Cells(i, 2).Value = Trim(Report.Cells(i, 2).Value)
If Report.Cells(j, 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(i, 2).Value, Report.Cells(j, 1).Value, vbTextCompare) > 0 Then
Report.Cells(j, 1).Interior.Color = xlNone 'Transparent background
Report.Cells(j, 1).Font.Color = RGB(0, 0, 0) 'Black font color
Exit For
Else
Report.Cells(j, 1).Interior.Color = RGB(156, 0, 6) 'Dark red background
Report.Cells(j, 1).Font.Color = RGB(255, 199, 206) 'Light red font color
End If
End If
Next i
Next j
By trimming the values, the instr returned true.
There are many ways to accomplish this.
You could use formulas, you could create dictionaries.
A Quick solution would be:
Dim stringCount As Integer
Dim myString As String
Dim col1Range As Range
Dim col2Range As Range
Set col1Range = Report.Range("A1")
Set col2Range = Report.Range("B1")
For i = 1 To LastRow
myString = col1Range.Offset(i).Value
If myString <> "" Then
stringCount = WorksheetFunction.CountIf(Range("B:B"), myString)
If (stringCount = 0) Then
col1Range.Offset(i).Interior.Color = RGB(156, 0, 6) 'Dark red background
col1Range.Offset(i).Font.Color = RGB(255, 199, 206) 'Light red font color
Else
col1Range.Offset(i).Interior.Color = xlNone 'Transparent background
col1Range.Offset(i).Font.Color = RGB(0, 0, 0) 'Black font color
End If
End If
Next i
For j = 1 To LastRow
myString = col2Range.Offset(j).Value
If myString <> "" Then
stringCount = WorksheetFunction.CountIf(Range("A:A"), myString)
If (stringCount = 0) Then
col2Range.Offset(j).Interior.Color = RGB(156, 0, 6) 'Dark red background
col2Range.Offset(j).Font.Color = RGB(255, 199, 206) 'Light red font color
Else
col2Range.Offset(j).Interior.Color = xlNone 'Transparent background
col2Range.Offset(j).Font.Color = RGB(0, 0, 0) 'Black font color
End If
End If
Next j
I am trying to make Excel cells look like buttons without actually inserting buttons.
For Each myCell In Range(BoardSize)
With myCell
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThick
.Borders.Color = RGB(110, 110, 110)
.Interior.Color = RGB(180, 180, 180)
End With
myCell.Borders(xlEdgeTop).Color = RGB(255, 255, 255)
myCell.Borders(xlEdgeLeft).Color = RGB(255, 255, 255)
Next myCell
It works for one cell:
but in a large range it looks like this:
What I want is something, without using actual command buttons, like:
For Each mycell In Range(BoardSize)
isblack = mycell.Row Mod 2 = 0 Xor mycell.Column Mod 2 = 0
With mycell
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThick
.Borders.Color = RGB(110, 110, 110)
.Interior.Color = RGB(180, 180, 180)
End With
If Not isblack Then
mycell.Borders(xlEdgeTop).Color = RGB(255, 255, 255)
mycell.Borders(xlEdgeLeft).Color = RGB(255, 255, 255)
End If
Next mycell
Another version with a minor artifact. It skipps odd rows and odd columns
Dim mycell As Range
For Each mycell In Range(BoardSize)
evenrow = mycell.Row Mod 2 = 0
evencol = mycell.Column Mod 2 = 0
isblack = evenrow Xor evencol
With mycell
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThick
.Borders.Color = RGB(110, 110, 110)
.Interior.Color = RGB(180, 180, 180)
End With
If Not isblack Then
mycell.Borders(xlEdgeTop).Color = RGB(255, 255, 255)
mycell.Borders(xlEdgeLeft).Color = RGB(255, 255, 255)
End If
If evenrow Or evencol Then mycell.Borders.Color = RGB(180, 180, 180)
If evencol And mycell.ColumnWidth <> 0.1 Then mycell.ColumnWidth = 0.1 Else mycell.ColumnWidth = 5
If evenrow And mycell.RowHeight <> 1 Then mycell.RowHeight = 1 Else mycell.RowHeight = 30
Next mycell
From the image below, I want to write a vba where cells in the column b will be equal to group above. So for example, column b for Activity 1.1 and Activity 1.2 would be equal to Group 1, and column b for Activity 2.1 and Activity 2.2 would be equal to Group 2.
c d e f g h i
Any ideas on where to start? Currently I have a two macros: One creates a group below a selected group and the other creates a line below a selected line. I'm thinking that when creating a new line I could somehow equate column b to the closest merged cell above my new line.
How could I find the closest merged cell above a selected row?
The code to create a new line is below:
Sub newLine()
Dim currCell As Integer
Dim newCell As Integer
currCell = ActiveCell.Select
Selection.Offset(1).EntireRow.Insert
ActiveCell.Offset(1, 0).Select
Cells(Selection.Row, 3).FormulaR1C1 = "=IF(RC4=""Complete"",1,IF(RC4=""Late"",2,IF(RC4=""At Risk"",3,IF(RC4=""On Schedule"",4,5))))"
With Cells(Selection.Row, 3)
.FormatConditions.Delete
.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=1"
.FormatConditions(1).Interior.Color = RGB(0, 112, 192)
.FormatConditions(1).Font.Color = RGB(0, 112, 192)
.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=2"
.FormatConditions(2).Interior.Color = RGB(192, 0, 0)
.FormatConditions(2).Font.Color = RGB(192, 0, 0)
.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=3"
.FormatConditions(3).Interior.Color = RGB(255, 192, 0)
.FormatConditions(3).Font.Color = RGB(255, 192, 0)
.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=4"
.FormatConditions(4).Interior.Color = RGB(146, 208, 80)
.FormatConditions(4).Font.Color = RGB(146, 208, 80)
.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=5"
.FormatConditions(5).Interior.Color = RGB(255, 255, 255)
.FormatConditions(5).Font.Color = RGB(255, 255, 255)
End With
Cells(Selection.Row, 4).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="Complete, Late, At Risk, On Schedule"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = "Select Status"
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
Cells(Selection.Row, 4) = "[Enter Status]"
Cells(Selection.Row, 4).HorizontalAlignment = xlLeft
Cells(Selection.Row, 5) = "[Enter Activity]"
Cells(Selection.Row, 5).HorizontalAlignment = xlLeft
Cells(Selection.Row, 6) = "[Enter Task]"
Cells(Selection.Row, 6).HorizontalAlignment = xlLeft
Cells(Selection.Row, 7) = "[Enter Responsability]"
Cells(Selection.Row, 7).HorizontalAlignment = xlLeft
Cells(Selection.Row, 8) = "[Enter Start Date]"
Cells(Selection.Row, 8).HorizontalAlignment = xlRight
Cells(Selection.Row, 9) = "[Enter Comp Date]"
Cells(Selection.Row, 9).HorizontalAlignment = xlRight
Range(Cells(Selection.Row, 4), Cells(Selection.Row, 9)).Font.Bold = False
Range(Cells(Selection.Row, 4), Cells(Selection.Row, 9)).Font.Size = 8
Range(Cells(Selection.Row, 4), Cells(Selection.Row, 9)).RowHeight = 11.25
Range(Cells(Selection.Row, 4), Cells(Selection.Row, 7)).HorizontalAlignment = xlLeft
Range(Cells(Selection.Row, 4), Cells(Selection.Row, 7)).NumberFormat = "General"
Range(Cells(Selection.Row, 8), Cells(Selection.Row, 9)).HorizontalAlignment = xlRight
Range(Cells(Selection.Row, 8), Cells(Selection.Row, 9)).NumberFormat = "m/d/yyyy"
End Sub
Any ideas?
Thank you!
MergeCells can help you out here.
Sub WhichLineIsMerged()
Dim row As Long
For row = ActiveCell.row To 1 Step -1
If Cells(row, 1).MergeCells Then
MsgBox "There are merged cells in row " & row
End If
Next row
End Sub
This sub only checks one cell on each line. As written, it checks Column A. You can adjust as needed.
In case anyone was interested, here's how I solved this:
Sub testGroupNum()
Dim i As Long
Dim LastRow As Integer
Dim startRow As Integer
LastRow = Cells(Rows.Count, "H").End(xlUp).Row
startRow = Selection.Row
For i = startRow To 11 Step -1
If Cells(i, 4).MergeCells = True Then
Cells(startRow, 2) = Cells(i, 4)
Exit For
End If
Next
End Sub