how to write code in vba if I want the another column to fill with yellow color when one column is not null?
For example:
if A1,A3,A8,A100 is not null:
fill background of B1,B3,B8,B100 into yellow color
If a loop is used would be great because my actual case have 7000 cells to fill instead of 4
Option Explicit
Sub ColorColA()
Dim ws As Worksheet
Dim lastrow As Long, cell As Range
Set ws = ThisWorkbook.Sheets("Sheet1")
lastrow = ws.Range("B" & Rows.Count).End(xlUp).Row
For Each cell In ws.Range("A1:A" & lastrow)
If IsEmpty(cell) Then
cell.Offset(0, 1).Interior.Color = RGB(255, 255, 0) 'yellow
Else
cell.Offset(0, 1).Interior.Pattern = xlNone ' remove color
End If
Next
MsgBox lastrow & " rows scanned", vbInformation
End Sub
Related
I am trying to set the cell colors of a range of cells based on the data that's been inputted.
The row will change based on what row is currently active, but the columns will remain the same.
I want to change the cell color to black if the active cell is "N/A". I keep getting Run-Time Error 13: Type Mismatch. I'm trying to color columns D:F in whichever row is currently selected. My snip of code is below.
Sub black_out_range()
Dim wsC As Worksheet
Dim jobRange As Range
Dim jobRange As Range
Set wsC = Worksheets("Sheet1")
Set jobRange = Range("B10", Range("B10").End(xlDown))
jobRange.Select
If TypeName(Selection) = "Range" Then
For Each i In jobRange
i.Activate
If ActiveCell = "N/A" Then
With wsC
.Range(.Cells(4, i), .Cells(6, i)).Interior.Color = RGB(0, 0, 0)
End With
Thanks in advance!
It's usually best to try to avoid using select and activate in VBA, especially when you are trying to loop through a range
This code will look at the values in column b starting at row 10 (to the last row of data) and then color d-f black is the value in B is "N/A".
Sub black_out_range()
Dim last_row As Long
last_row = Range("B10").End(xlDown).Row()
For i = 10 To last_row
If Cells(i, 2).Value = "N/A" Then 'asumes you want to start looking at cell b10
Range("D" & i & ":F" & i).Interior.Color = RGB(0, 0, 0)
End If
Next i
End Sub
You did not answer my clarification question, so I will try assuming that you try dealing with the real error #N/A. If so, please try the next code. It also avoids selecting, which does not bring any benefit, only consumes Excel resources decreasing the code speed:
Sub black_out_range()
Dim wsC As Worksheet, lastR As Long, i As Long
Set wsC = Worksheets("Sheet1")
lastR = wsC.Range("B" & rows.count).End(xlUp).row() 'it returns the last cell even with gaps in the range
For i = 10 To lastR
If IsError(wsC.Range("B" & i).Value) Then
If wsC.Range("B" & i).Value = CVErr(2042) Then 'the error for '#N/A' type
wsC.Range("D" & i & ":F" & i).Interior.Color = RGB(0, 0, 0)
End If
End If
Next i
End Sub
But, if you really have a "N/A" in those cells, please use the next version:
Sub black_out_range_bis()
Dim wsC As Worksheet, lastR As Long, i As Long
Set wsC = Worksheets("Sheet1")
lastR = wsC.Range("B" & rows.count).End(xlUp).row()
For i = 10 To lastR
If wsC.Range("B" & i).Value = "N/A" Then
wsC.Range("D" & i & ":F" & i).Interior.Color = RGB(0, 0, 0)
End If
Next i
End Sub
I'm trying to find a VBA code that would highlight appropriate row within the range "A7:AD100" if a cell in the column "AB" has value "Elective."
Sub highlight()
Dim cell As Range
Range(Range("AB7"), Range("AB7").End(xlDown)).Select
For Each cell In Selection
If cell = "Elective" Then Cells.Range($A7, $AD7).Interior.ColorIndex = 10
Next cell
End Sub
Only rows 1, 11, 21, 23 are highlighted since they have Admit Type = "Elective". The rows highlighted only within the range "A:AD" (I don't want the whole row to be highlighted).
I found this code that works for me
Sub HighlightCells()
Dim rngMyCell As Range
Dim lngLastRow As Long
Application.ScreenUpdating = False
lngLastRow = Cells(Rows.Count, "AB").End(xlUp).Row
For Each rngMyCell In Range("AB7:AB" & lngLastRow)
If StrConv(rngMyCell, vbProperCase) = "Elective" Then
Range("A" & rngMyCell.Row & ":AD" & rngMyCell.Row).Interior.Color = RGB(240, 240, 240)
End If
Next rngMyCell
Application.ScreenUpdating = True
End Sub
I am new to the macro world, I am trying to write the VBA to highlight the column heading in Red (7th Row is column heading in my sheet) if any of the cells in that column contains red colour if not then the column heading should be highlighted as green. I tried the below code but it is highlighting all the column heading as green.
Dim headers As Range, body As Range
Set headers = ActiveSheet.UsedRange.Rows(7).Columns
Set body = ActiveSheet.UsedRange.Offset(1).Columns
For Each body In Range(Range("A11:BD11"), Range("a" & Rows.Count).End(xlUp))
If body.Interior.Color = vbRed Then
headers.Interior.Color = IIf(found, vbRed, vbGreen)
End If
Next
try this:
Dim body As Range, ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1") 'Change Sheet1 for the name of the sheet
With ws
For Each body In .Range(.Range("A11"), .Range("BD" & .Cells(.Rows.Count, 1).End(xlUp).Row)
If body.Interior.Color = vbRed And _
Not .Cells(1, body.Column).Interior.Color = IIf(found, vbRed, vbGreen) Then 'To avoid doing it each time a cell on the same colour meets the criteria
.Cells(1, body.Column).Interior.Color = IIf(found, vbRed, vbGreen)
End If
Next
End With
You were taking ranges wrong, and when looping a range you don't set the variable before. It will be set on the For loop
You could use:
Option Explicit
Sub test()
Dim cell As Range, rng As Range
With ThisWorkbook.Worksheets("Sheet1")
'Set the range to loop
Set rng = .Range("A11:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
'Loop range
For Each cell In rng
If cell.Interior.Color = vbRed Then
'If cell interior is red then color Header(Row 7)
.Cells(7, cell.Column).Interior.Color = vbGreen
'Exit the loop after the first match
Exit For
Else
'If there is no match leave no fill
.Cells(7, cell.Column).Interior.ColorIndex = 0
End If
Next cell
End With
End Sub
So I have this code which lists through all sheets and compare cells in the 2nd row with cells in the 11th row. If they do not match it changes their color to red:
Dim tbl As ListObject
Dim sht As Worksheet
Dim i As Integer
'Loop through each sheet and table in the workbook
For Each sht In ThisWorkbook.Worksheets
For i = 1 To 1000
If sht.Cells(1, i) <> vbNullString Then
If sht.Cells(2, i).Value = sht.Cells(11, i).Value Then
sht.Cells(2, i).Interior.Color = xlNone
sht.Cells(11, i).Interior.Color = xlNone
Else
sht.Cells(2, i).Interior.Color = RGB(255, 0, 0)
sht.Cells(11, i).Interior.Color = RGB(255, 0, 0)
End If
Else
Exit For
End If
Next i
However in one tab it colors some matching cells as well. The data I am comparing is an exported csv. If i manually rewrite the value of the compared cell and run the code the result is correct. The formating of cells is general in both rows. Any ideas how to fix this?
I am tying to manage duplicates on an Excel sheet by having the duplicate cells turn red. I put this in a use to sheet protection to keep from editing the conditional formatting for these columns. However, when I move the cell information (by clicking and dragging) the conditional formatting moves from that cell as well. At the end of the day, I do not have duplicate coverage for every cell that I want. Is there some way I can prevent this from happening when I move the cell, or what macro can I put in to take care of this?
I want to do something like this using VBA:
Sub Duplicate()
Dim rngData As Range
Dim cell As Range
Set rngData = Range("P3:P19, P56:P58, P39:P42, P21:P25, P27:P37, P39:P42, P39:P42, P44:P54, M25:M76, B69:B77, B66:E67, B51:B64, H44:H47, D44:D47, H42, H33:H40, D33:D42, H31, D28:D31, H28:H29, D5:D8" & Cells(Rows.Count, "B").End(xlUp).Row)
For Each cell In rngData
cell.Offset(0, 0).Font.Color = vbBlack ' DEFAULT COLOR
' LOCATE DUPLICATE VALUE(S) IN THE SPECIFIED RANGE OF DATA.
If Application.Evaluate("COUNTIF(" & rngData.Address & "," & cell.Address & ")") > 1 Then
cell.Offset(0, 0).Font.Color = vbRed ' CHANGE FONT COLOR TO RED.
End If
Next cell
Set rngData = Nothing
Application.ScreenUpdating = True
End Sub
But I get a "Type Mismatch" error at:
If Application.Evaluate("COUNTIF(" & rngData.Address & "," & cell.Address & ")") > 1 Then
How can I get around this?
As per comment you would need to loop twice:
Sub Duplicate()
Dim rngData As Range
Dim cell As Range
Dim cell2 As Range
Set rngData = Range("P3:P19, P56:P58, P39:P42, P21:P25, P27:P37, P39:P42, P39:P42, P44:P54, M25:M76, B69:B77, B66:E67, B51:B64, H44:H47, D44:D47, H42, H33:H40, D33:D42, H31, D28:D31, H28:H29, D5:D8" & Cells(Rows.Count, "B").End(xlUp).Row)
rngData.Font.Color = vbBlack
For Each cell In rngData
If cell.Font.Color = vbBlack Then
For Each cell2 In rngData
If cell = cell2 And cell.Address <> cell2.Address Then
cell.Font.Color = vbRed
cell2.Font.Color = vbRed
End If
Next
End If
Next
Set rngData = Nothing
Application.ScreenUpdating = True
End Sub