Macro not working when I "Call" it from another macro, but does work when I select it individually - excel

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)

Related

How to copy specific rows to another sheet below black cell

I want to write a macro to copy rows from one worksheet to another below cell that is colored black (manually) - if it is detected, otherwise just copy rows from first sheet to Sheet1 at the top. After many trials and errors I came up with that code:
Sub copytherows(clf As Long, lastcell As Long) 'clf - cell that marks the start, lastcell - ending cell
Dim st As Long, cnext As Range
Dim wshet As Worksheet
Dim wshetend As Worksheet
'st - start of looking up, cnext - range of lines, wshet - worksheet
Dim coprange As String
Dim cnextcoprow, cnextrow As Long
'variables for copying macro part
Dim rangehelper As Range
Dim TargetColor As Long
Dim cell As Range
Dim sht As Worksheet
Dim x As Long
Dim Aend As Long
Set wshet = Worksheets(1)
Set wshetend = Sheets("Sheet1")
wshetend.Cells.Delete
For st = 1 To wshet.Cells(Rows.Count, "B").End(xlUp).Row
If wshet.Cells(st, "B").Interior.Color = clf Then 'has the color of interest
cnextcoprow = st
Set cnext = wshet.Cells(st, "B").Offset(1, 0) 'next cell down
Do While cnext.Interior.Color <> lastcell
Set cnext = cnext.Offset(1, 0) 'next row
Loop
st = st + 1
End If
Next st
cnextrow = cnext.Row - 1
coprange = cnextcoprow & ":" & cnextrow
Aend = Cells(Rows.Count, "A").End(xlUp).Row
'set color is black
TargetColor = RGB(255, 255, 255)
wshetend.Activate
For x = 1 To Rows.Count
If wshetend.Cells(x, "A").Interior.Color = TargetColor Then
x = x + 1
Set rangehelper = wshetend.Rows(x)
wshet.Range(coprange).Copy wshetend.Range(rangehelper).Offset(1)
Else
wshet.Range(coprange).Copy wshetend.Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next x
End Sub
When Macro is ran it displays an error(Run-time error '1004' Method 'Range' of object '_Worksheet' failed on line :
wshet.Range(coprange).Copy wshetend.Range(rangehelper).Offset(1)
Sheet1 is for sure present in Workbook.
Edit as suggested by #FaneDuru:
1 - in this image is my curret state of worksheet that is wshet in my macro and for example if I select (by checkboxes) section1 and section3, section3 should be in the place of black cell in section1 (the order of sections doesn't really matter to me) inside destination sheet ( I know I'm not good in explaining things like that).
2 - this should be end result of this macro
It's quite confusing how you use the for loops.
In the first one you use it to check for the start -which is fine- but then you put a while loop in there which will end up in an endless loop once your st gets past your lastcell row, instead use
ElseIf wshet.Cells(st, "B").Interior.Color = lastcell Then
cnextrow = st
Exit For
End If
In the second for loop you copy the rows if you find the black cell but you don't exit the for loop, speaking of which, you delete all the cells in your wshetend so you'll always start at row 1. So either you don't want to delete all the cells in your wshetend or the for loop is unnecessary.
This is my testSub and it copies from the first sheet to Sheet2 after the cell with black background (black = 0) (commented out the delete cells)
Sub TestBlackCellCopy()
Dim st As Long, cnext As Range
Dim wshet As Worksheet
Dim wshetend As Worksheet
'st - start of looking up, cnext - range of lines, wshet - worksheet
Dim coprange As String
Dim cnextcoprow, cnextrow As Long
'variables for copying macro part
Dim rangehelper As Range
Dim TargetColor As Long
Dim cell As Range
Dim sht As Worksheet
Dim x As Long
Dim Aend As Long
Dim clf As Long, lastcell As Long
clf = 5296274
lastcell = 65535
cnextcoprow = 0
Set wshet = Worksheets(1)
Set wshetend = Sheets("Sheet1")
' wshetend.Cells.Delete
For st = 1 To wshet.Cells(Rows.Count, "B").End(xlUp).Row
Debug.Print (wshet.Cells(st, "B").Interior.Color)
If wshet.Cells(st, "B").Interior.Color = clf And cnextcoprow = 0 Then 'has the color of interest
cnextcoprow = st
ElseIf wshet.Cells(st, "B").Interior.Color = lastcell Then
cnextrow = st - 1
Exit For
End If
Next st
coprange = cnextcoprow & ":" & cnextrow
Aend = Cells(Rows.Count, "A").End(xlUp).Row 'unused variable?
'set color is black
TargetColor = 0
wshetend.Activate
For x = 1 To Rows.Count
Debug.Print (wshetend.Cells(x, "A").Interior.Color)
If wshetend.Cells(x, "A").Interior.Color = TargetColor Then
wshet.Rows(coprange).EntireRow.Copy wshetend.Range("A" & x).Offset(1)
Exit For
' Else
' wshet.Range(coprange).Copy wshetend.Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next x
End Sub
So you'll have to figure out what exactly you want, to delete the cells? Then it starts at row 1, then put a skip after a copy you place after the second for loop.
Something like this:
wshetend.Activate
Aend = Cells(Rows.Count, "A").End(xlUp).Row
For x = 1 To Rows.Count
Debug.Print (wshetend.Cells(x, "A").Interior.Color)
If wshetend.Cells(x, "A").Interior.Color = TargetColor Then
wshet.Rows(coprange).EntireRow.Copy wshetend.Range("A" & x).Offset(1)
GoTo skipFor
End If
Next x
wshet.Rows(coprange).EntireRow.Copy wshetend.Range("A1")
skipFor:
Hope this helps.
Please, try the next way. It should work if you respected all what we set in the above discussion (check boxes in G:G, black cells in B:B for first sheet, and a black cell in any place of the second sheet:
Sub CopyRowsCheckBox_Black_limited()
Dim wshet As Worksheet, wshetend As Worksheet, blackCell As Range, redCell As Range, rngCopy As Range
Dim sh As Shape, chkB As MSForms.CheckBox, cellPaste As Range, pasteRow As Long
Set wshet = ActiveSheet 'use here the sheet where from you need copying
Set wshetend = wshet.Next 'use here the sheet where to copy
'settings to make Find function searching for Interior color:
With Application.FindFormat
.Clear: .Interior.Color = vbBlack
.Locked = True
End With
'find the black cell in the second sheet:
Set cellPaste = wshetend.cells.Find(What:=vbNullString, After:=wshetend.Range("A1"), SearchFormat:=True)
If Not cellPaste Is Nothing Then 'set the row where to copy first
pasteRow = cellPaste.Offset(1).row
Else
pasteRow = 1
End If
'iterate between all shapes, found the ones being checkBoxes and being on column G:G, set the rows range and copy it:
For Each sh In wshet.Shapes
If TypeName(sh.OLEFormat.Object.Object) = "CheckBox" And sh.TopLeftCell.Column = 7 Then
Set chkB = sh.OLEFormat.Object.Object 'set the checkBox ActiveX object
If chkB.Value = True Then 'if it is checked
Set blackCell = wshet.Range("B:B").Find(What:=vbNullString, After:=wshet.Range("B" & _
sh.TopLeftCell.row), SearchFormat:=True) 'find first black cell
Set rngCopy = wshet.Range(wshet.Range("B" & sh.TopLeftCell.row), blackCell).EntireRow 'set the rows to be copied
rngCopy.Copy wshetend.Range("A" & pasteRow): pasteRow = pasteRow + rngCopy.rows.count 'copy and update pasting row
End If
End If
Next sh
MsgBox "Ready..."
End Sub
The range to be copied is the one between the checked check box and the first black cell in B:B column.
Important Note: The top left corner of the check boxes must be inside of first series row!
Please, send some feedback after testing it.

VBA color row with specific value/string upto the last column

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

Setting Excel cell content based on row font color

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 Excel how to replace cell interior color with two conditions

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

Delete rows based on cell value not working

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

Resources