I would like to color rows with specific cell values (string) in a data set.
I have come across the following code which works perfectly with "entire row" but I would like to color the row only up to the last column which contains some value (and there are spaces in between).
I have tried to specify the last column and use it with Range to color, but it does not go well with vCell...
Thank you for the help!
Sub Highlight()
Dim vCell As Range
'Loop through every used cell in the active worksheet
For Each vCell In ActiveSheet.UsedRange
If InStr(vCell.Value, "anyword") Then
vCell.Font.Color = RGB(0, 0, 0)
vCell.EntireRow.Interior.Color = RGB(204, 255, 204)
End If
Next
End Sub
Try below modified sub.
Sub Highlight()
Dim vCell As Range
Dim lastCol As Long
'Loop through every used cell in the active worksheet
For Each vCell In ActiveSheet.UsedRange
If InStr(vCell.Value, "anyword") Then
vCell.Font.Color = RGB(0, 0, 0)
lastCol = Cells(vCell.Row, Columns.Count).End(xlToLeft).Column
Range(Cells(vCell.Row, vCell.Column), Cells(vCell.Row, lastCol)).Interior.Color = RGB(204, 255, 204)
End If
Next
End Sub
Is this what you are trying?
Option Explicit
Sub Highlight()
Dim vCell As Range
Dim lCol As Long
Dim ws As Worksheet
'~~> Set this to the relevant worksheet
Set ws = Sheet1
With ws
'~~> Loop through every used cell in the active worksheet
For Each vCell In .UsedRange
If InStr(vCell.Value, "anyword") Then
vCell.Font.Color = RGB(0, 0, 0)
'~~> Find last column in that row
lCol = .Cells(vCell.Row, .Columns.Count).End(xlToLeft).Column
.Range(.Cells(vCell.Row, 1), .Cells(vCell.Row, lCol)).Interior.Color = RGB(204, 255, 204)
End If
Next
End With
End Sub
Related
I have tabs in an Excel document (e.g. 580400 / 580401 / 580402 / 580403).
Some of the entry lines in each tab have conditional formatting to turn some of the lines blue.
I am trying to copy all the blue font lines to another tab called "Sheet2" within the same workbook.
I made this work on one tab (580400).
How do I include the other tabs (580401 / 580402 / 580403)?
Sub CopyColouredFontTransactions()
Dim PeriodField As Range
Dim PeriodCell As Range
Dim Sheet1WS As Worksheet
Dim Sheet2WS As Worksheet
Dim x As Long
Set Sheet1WS = Worksheets("580400")
Set PeriodField = Sheet1WS.Range("A2", Sheet1WS.Range("A2").End(xlDown))
Set Sheet2WS = Worksheets("Sheet2")
For Each PeriodCell In PeriodField
If PeriodCell.Font.Color = RGB(0, 176, 240) Then
PeriodCell.Resize(1, 15).Copy Destination:= _
Sheet2WS.Range("A1").Offset(Sheet2WS.Rows.Count - 1, 0).End(xlUp).Offset(1, 0)
End If
Next PeriodCell
Sheet2WS.Columns.AutoFit
End Sub
you could try add a for next loop that will iterate an array of worksheets name. See example below (not tested)
Sub CopyColouredFontTransactions()
Dim PeriodField As Range
Dim PeriodCell As Range
Dim Sheet1WS As Worksheet
Dim Sheet2WS As Worksheet
Dim x As Long
Set Sheet2WS = Worksheets("Sheet2")
Dim tabs As Variant
Set tabs = Array("580400", "580401", "580403")
Dim tabname As String
For Each tabname In tabs
Set Sheet1WS = Worksheets(tabname)
Set PeriodField = Sheet1WS.Range("A2", Sheet1WS.Range("A2").End(xlDown))
For Each PeriodCell In PeriodField
If PeriodCell.Font.Color = RGB(0, 176, 240) Then
PeriodCell.Resize(1, 15).Copy Destination:= _
Sheet2WS.Range("A1").Offset(Sheet2WS.Rows.Count - 1, 0).End(xlUp).Offset(1, 0)
End If
Next PeriodCell
Next tabs
Sheet2WS.Columns.AutoFit
End Sub
I managed to get this code:
Sub ColorChange()
Dim ws As Worksheet
Set ws = Worksheets(2)
clrOrange = 39423
clrWhite = RGB(255, 255, 255)
If ws.Range("D19").Value = "1" And ws.Range("E19").Value = "1" Then
ws.Range("D19", "E19").Interior.Color = clrOrange
ElseIf ws.Range("D19").Value = "0" Or ws.Range("E19").Value = "0" Then
ws.Range("D19", "E19").Interior.Color = clrWhite
End If
End Sub
This works, but now I need this code to work in 50 rows and 314 cells, but every time only on two cells so, D19+E19, D20+E20, etc. Endpoint is DB314+DC314.
Is there a way, without needing to copy paste this code and replacing all the row and cells by hand?
It also would be nice that if the value in the two cells is anything other than 1+1 the cell color changes back to white.
EDIT: The solution thanks to #VBasic2008.
I added the following to the sheet's code to get the solution to work automatically:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("D19:DC314")) Is Nothing Then
Call ColorChange
End If
End Sub
And because Interior.Color removes borders I added the following sub:
Sub vba_borders()
Dim iRange As Range
Dim iCells As Range
Set iRange = Range("D19:DC67,D70:DC86,D89:DC124,D127:DC176,D179:DC212,D215:DC252,D255:DC291,D294:DC314")
For Each iCells In iRange
iCells.BorderAround _
LineStyle:=xlContinuous, _
Weight:=xlThin
Next iCells
End Sub
The Range is a bit different to exclude some rows.
Compare Values in the Two Cells of Column Pairs
Option Explicit
Sub ColorChange()
Const rgAddress As String = "D19:DC314"
Const Orange As Long = 39423
Const White As Long = 16777215
Dim wb As Workbook ' (Source) Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
Dim rg As Range ' (Source) Range
Set rg = wb.Worksheets(2).Range(rgAddress) ' Rather use tab name ("Sheet2").
Dim cCount As Long ' Columns Count
cCount = rg.Columns.Count
Dim brg As Range ' Built Range
Dim rrg As Range ' Row Range
Dim crg As Range ' Two-Cell Range
Dim j As Long ' (Source)/Row Range Columns Counter
For Each rrg In rg.Rows
For j = 2 To cCount Step 2
Set crg = rrg.Cells(j - 1).Resize(, 2)
If crg.Cells(1).Value = 1 And crg.Cells(2).Value = 1 Then
If brg Is Nothing Then
Set brg = crg
Else
Set brg = Union(brg, crg)
End If
End If
Next j
Next rrg
Application.ScreenUpdating = False
rg.Interior.Color = White
If Not brg Is Nothing Then
brg.Interior.Color = Orange
End If
Application.ScreenUpdating = True
End Sub
I have a formatting macro below:
Sub Colour_whole_sheet()
Dim lastRow As Long
Dim lastColumn As Long
lastRow = Range("A1").End(xlDown).Row
lastColumn = Range("A3").End(xlToRight).Column
'Colour alternate rows purple / white
For Each cell In Range(Cells(1, 1), Cells(lastRow, lastColumn))
If cell.Row Mod 2 = 1 Then
cell.Interior.Color = RGB(242, 230, 255)
Else
cell.Interior.Color = RGB(255, 255, 255)
End If
Next cell
End Sub
It doesn't run when I call it from another macro, which is just:
Sub Run_macros()
[A bunch of other subs]
Call Colour_whole_sheet
[A bunch of other subs]
End Sub
It doesn't come up with an error - it just doesn't do anything. But when I select it specifically on its own, from View > Macros > View Macros > Run, it works fine.
Do you know why this might be?
EDIT:
Sub Colour_whole_sheet()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Calendar")
Dim lastRow As Long
Dim lastColumn As Long
lastRow = ws.Range("A1").End(xlDown).Row
lastColumn = ws.Range("A3").End(xlToRight).Column
'Colour alternate rows purple / white
For Each cell In ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastColumn))
If cell.Row Mod 2 = 1 Then
cell.Interior.Color = RGB(242, 230, 255)
Else
cell.Interior.Color = RGB(255, 255, 255)
End If
Next cell
End Sub
you might be after this revision of your code
Sub Colour_whole_sheet(Optional sht As Variant)
If IsMissing(sht) Then Set sht = ActiveSheet ' if no argument is passed assume ActiveSheet
Dim lastRow As Long
Dim lastColumn As Long
Dim i As Long
With sht ' reference passed/assumed sheet object
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row ' best way to get a column last used cell row index
lastColumn = .Cells(3, .Columns.Count).End(xlToLeft).Column ' best way to get a row last used cell column index
'Colour alternate rows purple / white
With .Range("A1", Cells(lastRow, lastColumn)) ' reference all your range
.Interior.Color = vbWhite ' color it white
For i = 1 To .Rows.Count Step 2 ' loop through referenced range uneven rows
.Rows(i).Interior.Color = RGB(242, 230, 255) ' color them with purple
Next
End With
End With
End Sub
as you can see:
it always references some sheet(be it passed through sub argument or be it the active one)
it doesn't loop through all cells, but just through uneven rows
Here Range("A1") is not specified in which worksheet this range is. Always specify a worksheet for all your Range(), Cells(), Rows() and Columns() objects.
Otherwise it is very likely that your code runs on the wrong worksheet. Note that this is applicable to all your macros (not just this one). Check if you have specified a worksheet everywhere, or your code might randomly work or fail.
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'your sheet name here
Then adjust the following lines:
lastRow = ws.Range("A1").End(xlDown).Row
lastColumn = ws.Range("A3").End(xlToRight).Column
For Each cell In ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastColumn))
Also note that you can format an Excel table to get rows alternated colored.
Additional notes:
The method you used is not reliable in finding the last used row/column. Better do it the other way round. Start in the very last row and go xlUp.
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row 'Last used row
lastColumn = ws.Cells(3, ws.Columns.Count).End(xlToLeft).Column 'last used column in row 3
Also you don't need to go through all cells. Looping throug rows would do.
Dim i As Long
For i = 1 To lastRow
If i Mod 2 = 1 Then
ws.Rows(i).Interior.Color = RGB(242, 230, 255)
Else
ws.Rows(i)..Interior.Color = RGB(255, 255, 255)
End If
Next i
or if you don't want to color the whole row but only up to the last used column
ws.Cells(i, lastColumn).Interior.Color
Note that coloring each row on on its own can slow down a lot if there are many rows. Therefore I suggest to collect all even/uneven rows in a reference and color it at once.
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row 'Last used row
lastColumn = ws.Cells(3, ws.Columns.Count).End(xlToLeft).Column 'last used
Dim EvenRows As Range
Dim OddRows As Range
Dim i As Long
For i = 1 To lastRow
If i Mod 2 = 1 Then
If OddRows Is Nothing Then
Set OddRows = ws.Rows(i)
Else
Set OddRows = Union(OddROws, ws.Rows(i))
End If
Else
If EvenRows Is Nothing Then
Set EvenRows = ws.Rows(i)
Else
Set EvenRows = Union(EvenRows, ws.Rows(i))
End If
End If
Next i
If Not OddRows Is Nothing Then OddRows.Interior.Color = RGB(242, 230, 255)
If Not EvenRows Is Nothing Then EvenRows.Interior.Color = RGB(255, 255, 255)
I have some data in sheet called New, and my data are in column A to column K. However, column E to H are intentionally left blank for data analysis purposes and I have no header so my data starts from cell A1. Now in column A we have color in cell, I would like to delete any rows that aren't white so keep rows that don't have color in it.
I did some research but all of the codes I got online either delete the whole sheet or just pass through codes and nothing happens. Below are the ones I am currently using that doesn't do anything. I use F8 and still no error.
See image for my sample data and I am trying to get the results with cells that don't have any color in it. I tried to remove quotation mark for the color index but still it doesn't work.
Sub deleterow()
lastRow = Worksheets("New").Cells(Rows.Count, "A").End(xlUp).Row
For i = lastRow To 1 Step -1
If Worksheets("New").Cells(i, 1).Interior.ColorIndex <> "2" Then
Rows(i).EntireRow.Delete
i = i + 1
End If
Next I
End Sub
Try the code below:
Option Explicit
Sub deleterow()
Dim i As Long, LastRow As Long
With Worksheets("New")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = LastRow To 1 Step -1
'If .Cells(i, 1).Interior.Color <> xlNone Then
' replace RGB(255, 255, 255) with the "white" color
If .Cells(i, 1).Interior.Color <> RGB(255, 255, 255) Then
.Rows(i).Delete
End If
Next i
End With
End Sub
Delete No Color Row
Union Version
Option Explicit
Sub DeleteNoColorRow()
Const cSheet As Variant = "Sheet1" ' Worksheet Name/Index
Const cFirstR As Integer = 1 ' First Row
Const cColumn As Variant = "A" ' Column Letter/Number
Dim rngU As Range ' Union Range
Dim lastRow As Long ' Last Row
Dim i As Long ' Row Counter
With ThisWorkbook.Worksheets(cSheet)
lastRow = .Cells(.Rows.Count, cColumn).End(xlUp).Row
For i = cFirstR To lastRow
If .Cells(i, cColumn).Interior.ColorIndex <> xlNone Then
If Not rngU Is Nothing Then
Set rngU = Union(rngU, .Cells(i, cColumn))
Else
Set rngU = .Cells(i, cColumn)
End If
End If
Next
End With
If Not rngU Is Nothing Then
rngU.EntireRow.Delete ' Hidden = True
Set rngU = Nothing
End If
End Sub
I found a macro which counts conditionally formatted coloured cells.
'Variable declaration
Dim lColorCounter2 As Long
Dim rngCell2 As Range
'loop throughout each cell in the range
For Each rngCell2 In Selection
'Checking Amber color
If Cells(rngCell2.Row, rngCell2.Column).DisplayFormat.Interior.Color = RGB(255, 192, 0) Then
lColorCounter2 = lColorCounter2 + 1
End If
Next
MsgBox "Green =" & lColorCounter2
I am trying to change it into a function. I've read on here that it may be because .DisplayFormat.Interior.Color doesn't work for functions. Is there a workaround?
Ideally I would like the function to have two arguments, the range of cells to search in for the colours and the second a cell with the colour to look for.
Have in mind that:
RGB(255, 192, 0) is not green but close to orange.
Change the range you want to loop - rng (now rng equals to Sheet1.Range("A1:A20"))
Try:
Option Explicit
Public Function Color(ByVal rng As Range)
Dim Counter As Long
Dim Cell As Range
For Each Cell In rng
'Checking Amber color
If Cells(Cell.Row, Cell.Column).DisplayFormat.Interior.Color = RGB(255, 192, 0) Then
Counter = Counter + 1
End If
Next
MsgBox "Orange=" & Counter
End Function
Sub test()
Dim rng As Range
Set rng = Sheet1.Range("A1:A20")
Call Color(rng)
End Sub