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?
Related
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
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 have a spreadsheet that I'm trying to migrate into SQL.
The spreadsheet contains 65k rows of information over two worksheets.
The people operating the spreadsheet have been colouring the font in the rows either red, blue or yellow depending on the status of the record. Each row is a record with personal data etc. so I can't share online.
As part of the migration to SQL I need to add a column with a status field. The status field on each row should contain either 1, 2, 3, or 4 depending on whether the row has a black, red, blue or yellow font.
Based on searching here I believe it might be possible with a VBA function and a formula?
Could anyone help with what to do? I'm ok with Excel but not a power user by any means.
try using something like this in VBA. You will need to add several more ifs based on the colors you have.
CurrentSheetText="Sheet1"
LastRow = Sheets(CurrentSheetText).Cells.SpecialCells(xlCellTypeLastCell).Row
for iter = 1 to LastRow
if Sheets(CurrentSheetText).Cells(iter, 1).Interior.Color = RGB(255, 255, 0) Then
Sheets(CurrentSheetText).Cells(iter,5).value =1
End if
Next iter
This is very easily implemented with VBA. Due to the lack of information in the post, I can only write you a crude script
Sub AddCol()
Dim wb As Workbook
Dim ws As Worksheet
Dim LRow As Long, i As Long
'Target workbook
Set wb = Workbooks("NAME")
'Target worksheet
Set ws = wb.Sheets(INDEX)
'Target column
target_col = 1
'Output column
output_col = 10
With ws
'Find last row in sheet based on column A
LRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Loop through row 1 through LRow
For i = 1 To LRow
'populate output col based on target col's font colour
If .Cells(i, target_col).Font.Color = vbBlack Then
.Cells(i, output_col).Value = 1
ElseIf .Cells(i, target_col).Font.Color = vbRed Then
.Cells(i, output_col).Value = 2
ElseIf .Cells(i, target_col).Font.Color = vbBlue Then
.Cells(i, output_col).Value = 3
ElseIf .Cells(i, target_col).Font.Color = vbYellow Then
.Cells(i, output_col).Value = 4
End If
Next i
End With
End Sub
Many thanks for all the help!
It seems there is a very simple way to do this without any code!
I was able to use the filter function by highlighting the cheet and sorting by colour. Once I had all the red text together I was able to just add a 1 to each row and fill down.
Try the next function, please. It will return an array with the settled codes for analyzed colors. It take in consideration all standard nuances (especially for blue) of the colors in discussion:
Function colorNo(sh As Worksheet) As Variant
Dim lastR As Long, cel As Range, arr, k As Long
lastR = sh.Range("A" & rows.count).End(xlUp).row
ReDim arr(lastR - 2)
For Each cel In sh.Range("A2:A" & lastR)
Select Case cel.Font.Color
Case vbRed, 49407: arr(k) = 2: k = k + 1
Case vbBlue, 12611584, 6567712, 9851952, 14395790: arr(k) = 3: k = k + 1
Case vbYellow: arr(k) = 4: k = k + 1
Case Else: arr(k) = 1: k = k + 1
End Select
Next
colorNo = arr
End Function
The above code considers all other colors like being Black!
If in the future you will need some other colors, you should fill appropriate Case newColor lines...
It can be tested/used in this way:
Sub testColorNo()
Dim sh As Worksheet, arrCol As Variant
Set sh = ActiveSheet
arrCol = colorNo(sh)
'the array can be used like it is
'or its value can be dropped in the last empty column
'un comment the next line if you want to visually see the returned array
'but only on testing small range. Otherwise, it will be a huge string...
'Debug.Print Join(arrCol, ","): you can see the array content in Immediate Window
sh.cells(2, sh.UsedRange.Columns.count + 1).Resize(UBound(arrCol) + 1, 1).Value = _
WorksheetFunction.Transpose(arrCol)
End Sub
This should work:
Sub SubColor()
'Declarations.
Dim RngColouredRange As Range
Dim RngFirstAnswer As Range
Dim RngTarget As Range
Dim DblRow As Double
'Setting variables.
Set RngColouredRange = Range("M1:M5")
Set RngFirstAnswer = Range("N1")
'Covering each cell in RngColouredRange.
For Each RngTarget In RngColouredRange
'Checking font's color.
Select Case RngTarget.Font.Color
'In Case is black.
Case Is = 0
RngFirstAnswer.Offset(DblRow, 0) = 0
'In case is red.
Case Is = 255
RngFirstAnswer.Offset(DblRow, 0) = 1
'In case is blue.
Case Is = 12611584
RngFirstAnswer.Offset(DblRow, 0) = 2
'In case is yellow.
Case Is = 65535
RngFirstAnswer.Offset(DblRow, 0) = 3
'In other cases.
Case Else
RngFirstAnswer.Offset(DblRow, 0) = "Unclassified"
End Select
'Increasing DblRow.
DblRow = DblRow + 1
Next
End Sub
Edit the variables accordingly.
If you need to know what number refers to each of the fonts' color you have, use this:
Sub SubFontColourNumber()
'Declarations.
Dim RngColouredRange As Range
Dim RngFirstAnswer As Range
Dim RngTarget As Range
Dim DblRow As Double
'Setting variables.
Set RngColouredRange = Range("M1:M5")
Set RngFirstAnswer = Range("N1")
'Covering each cell in RngColouredRange.
For Each RngTarget In RngColouredRange
'Reporting the font's color.
RngFirstAnswer.Offset(DblRow, 0) = RngTarget.Font.Color
'Increasing DblRow.
DblRow = DblRow + 1
Next
End Sub
Like before, edit the variables accordingly.
In my Excel sheet, First condition is to Highlight the intersected cell with BLUE based on text matching of row and column.
Second condition: The cell values which are highlighted in Blue must Change to red if the cell value(date Format) is less than today's date.
I am able to fulfill first condition but failing to satisfy second condition.
The Excel data Looks like below:
First Condition:
Second Condition:Problem I am facing to get red interior
I am trying with a VBA Code as below:
Sub RunCompare()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim cols As Range, rws As Range
Dim lastRow As Integer: lastRow = ws.UsedRange.Rows.Count
Dim lastColumn As Integer: lastColumn = ws.UsedRange.Columns.Count
For Each cols In ws.Range(ws.Cells(4, 1), ws.Cells(4, lastColumn))
If cols.Value <> vbNullString Then
For Each rws In ws.Range("A1:A" & lastRow)
'first condition statement
If (rws.Value = cols.Value) Then
ws.Cells(rws.Row, cols.Column).Interior.Color = RGB(15, 219, 241)
End If
'second condition statement
If (rws.Value = cols.Value) < Date Then
ws.Cells(rws.Row, cols.Column).Interior.Color = RGB(255, 0, 0)
End If
Next
End If
Next
End Sub
This can easily be done with conditional formatting.
Add two rules based on these formulas:
RED: =AND($A3=B$1,B3<>"",B3<TODAY()).
BLUE: =AND($A3=B$1,B3<>"")
If you really want to keep your current VBA, you could change
If (rws.Value = cols.Value) < Date Then
to
If (rws.Value = cols.Value) And (ws.Cells(rws.Row, cols.Column).Value < Date) Then
Or you could simplify further, by moving the RED condition inside the existing BLUE condition check (rws.Value = cols.Value must be true for both red and blue.)
If rws.Value = cols.Value Then
With ws.Cells(rws.Row, cols.Column)
If .Value < Date Then
.Interior.Color = RGB(255, 0, 0) ' RED
Else
.Interior.Color = RGB(15, 219, 241) ' BLUE
End If
End With
End If
Is this solution OK for you?
Dim ws As Worksheet
Dim col As Integer
Dim row As Integer
Dim lastRow As Integer
Dim lastCol As Integer
Dim OK As Boolean
Set ws = ActiveSheet
lastRow = ws.UsedRange.Rows.Count
lastCol = ws.UsedRange.Columns.Count
For col = 1 To lastCol
For row = 2 To lastRow
If ws.Cells(row, 1).Value = ws.Cells(1, col).Value Then
If ws.Cells(row, col) < Date Then
ws.Cells(row, col).Interior.Color = RGB(255, 0, 0)
Else
ws.Cells(row, col).Interior.Color = RGB(15, 219, 241)
End If
End If
Next
Next
I've got multiple sheets with data in them. I've highlighted some rows in each sheet with different colors (mostly green), and I'd like to copy these, into one sheet
What I've got so far
Sub Copy_If_colored()
Dim sh As Worksheet, N As Long
Dim i As Long, M As Long, J As Long
Dim xCell As Range, xRg As Range
N = Sheets.Count - 1
M = 2
For i = 1 To N
J = Sheets(i).UsedRange.Rows.Count
Set xRg = Sheets(i).Range("A1:A" & J)
For Each xCell In xRg
If xCell.Interior.Color <> RGB(255, 255, 255) Then
Sheets(i).Range(xCell).Copy
Sheets("Recommended").Range("A" & M).PasteSpecial (xlValues)
Sheets("Recommended").Range("A" & M).PasteSpecial (xlFormats)
M = M + 1
End If
Next
Next i
End Sub
I was hoping the ..<> RGB(255, 255, 255) would catch any color since it's the value it returns in the default colorcode, right? Or would xlNone be more correct?
There are a few mistakes in your code, here is your fixed code:
Sub Copy_If_colored()
Dim sh As Worksheet
Dim i As Long, M As Long
Dim rngRow As Range
M = 2 'Start at second row, since first row contains headers
For i = 1 To Sheets.Count - 1 'Make sure "Recommended" is the last sheet
For Each rngRow In Sheets(i).UsedRange.Rows 'Going through rows instead of every cell should be considerably faster
If Sheets(i).Range("A" & rngRow.Row).Interior.ColorIndex <> xlNone Then
rngRow.Copy Sheets("Recommended").Range("A" & M)
M = M + 1
End If
Next
Next i
End Sub
To only copy the data as values, use this:
rngRow.Copy
Sheets("Recommended").Range("A" & M).PasteSpecial xlValues
Note that this does not copy formatting, if you need number formats etc. to be copied as well, add this line:
Sheets("Recommended").Range("A" & M).PasteSpecial xlFormats
If You want to compare with RGB instead of:
If CStr(xCell.Value) <> RGB(255, 255, 255) Then
try to use:
If xCell.Interior.Color <> RGB(255, 255, 255) Then
Also You need to set range xRg