Copy To New Sheet

[DavidH56]

Hi,

I have code which copies rows to a new sheet based on certain criteria.

Dim SearchRange As Range
Dim EachCell As Range
Dim CopyRange As Range
Dim nSh As Worksheet
Dim LastRow As Long



Application.ScreenUpdating = False
Columns("N:N").Hidden = False

'Set SearchRange = ActiveSheet.Range("C1:Q5000")
LastRow = Cells(Rows.Count, "F").End(xlUp).Row
Set SearchRange = ActiveSheet.Range("C1:Q" & LastRow)

For Each EachCell In SearchRange
If EachCell.Font.ColorIndex = 3 Or EachCell.Interior.ColorIndex
= 3 _
Or EachCell.Font.Bold Or EachCell.Interior.ColorIndex = 6 _
Or EachCell.Font.Color <> vbBlack Or
EachCell.Interior.ColorIndex = 8 _
Or EachCell.Interior.ColorIndex = 33 Then
'Or EachCell.Font.ColorIndex = "Custom color or no fill" Then
If Not CopyRange Is Nothing Then
Set CopyRange = Union(CopyRange, EachCell.EntireRow)
Else
Set CopyRange = EachCell.EntireRow
End If
End If
Next EachCell
CopyRange.Copy
Set nSh = Worksheets.Add
nSh.Range("A1").PasteSpecial xlPasteAll
Columns("A").Select
Columns("A").EntireColumn.AutoFit
Cells.Select
With Selection.Font
.Name = "Arial"
.Size = 8
End With

I would like to also copy the row if only certain characters or words are
red as opposed to the entire cell containing red font. Some of the words may
be black and red within one cell.

If some could please assist I surely would appreciate it.

 

[OssieMac]

Hello David,

Perhaps these code examples will help to point you in the right direction.
Note the use of Select Case in lieu of complex If statements with lots of
Or’s.

Because you have used ColorIndex, I have coded using ColorIndex but note
that you could have colors that do not have a ColorIndex in which case you
should use color but you will need to identify the color. Personally I think
it is safer to use colors and you can replace the ColorIndex code with Color
but of course the values will be different.

To identify a color: MsgBox Range("A5").Font.Color.

The first case tests for cells with ColorIndex specifics. Only cells with
entire cell same color and match the parameters get processed here.

The second one looks for cells with any ColorIndex. These will be those that
do not get processed by the first Case but entire cell has same ColorIndex.

Case Else is the leftovers and in this example represent the cells with
mixed colors because the ColorIndex does not return a value for cells with
mixed colors. (I have not been able to identify any specific about the
returned value such as Null or zero or anything else but the cells with mixed
colors are these leftovers.) You could then incorporate the second example
below to identify the colors within such a cell.

A word of warning. Cells that appear black are not always ColorIndex 1. The
default ColorIndex returned by my xl2002 is -4105.

Sub Macro1()

Dim SearchRange As Range
Dim EachCell As Range

Set SearchRange = ActiveSheet.Range("A:A")

For Each EachCell In SearchRange
Select Case EachCell.Font.ColorIndex

Case 3, 6, 8, 33, Not 1
MsgBox EachCell.Address & _
" ColorIndex is " & _
EachCell.Font.ColorIndex

Case 1 To 56 'Any other cell with a color index
MsgBox EachCell.Address & _
" Case 1 to 56 value is " _
& EachCell.Font.ColorIndex

Case Else
MsgBox EachCell.Address & _
" Case Else value is " _
& EachCell.Font.ColorIndex

End Select

Next EachCell

End Sub


To identify individual character colors in a cell
For i = 1 To Len(EachCell)
c = EachCell.Characters(i, 1).Font.ColorIndex
MsgBox EachCell.Address(0, 0) & " Chr " & i & " is " & c
Next i

 

[DavidH56]

Thanks OssieMac for your reply. I've been trying to get your code to work
for me. I've simplified to test it:

LastRow = Cells(Rows.Count, "F").End(xlUp).Row
Set SearchRange = ActiveSheet.Range("C1:Q" & LastRow)

For Each EachCell In SearchRange
Select Case EachCell.Font.ColorIndex
Case 3
End Select


If Not CopyRange Is Nothing Then
Set CopyRange = Union(CopyRange, EachCell.EntireRow)
Else
Set CopyRange = EachCell.EntireRow
End If

Next EachCell

CopyRange.Copy


This should copy all rows that has red font. But it copies everything. I
don't understand what I'm doing incorrectly.

 

[OssieMac]

Hi David,

The code to be processed when a match is found needs to be inside the Case
where the match was found. I have also added another test for a cell with
mixed colors. The IsNull function returns true if the cell has mixed colors.
You would then need the code I posted previously to test for what actual
colors are in the cell.

As an added commment, the code appears to continue testing the remainder of
a row after it has found a match and added the EntireRow to CopyRange. It
would be more professional to break SearchRange into separate rows with
another nested For/Next loop and break out of the loop with Exit For when a
match has been found in a row because there is no need to continue testing
the row.

Dim LastRow As Long
Dim SearchRange As Range
Dim searchRow As Range
Dim CopyRange As Range
Dim EachCell As Range

LastRow = Cells(Rows.Count, "F").End(xlUp).Row

Set SearchRange = ActiveSheet.Range("C1:Q" & LastRow)

For Each EachCell In SearchRange

Select Case EachCell.Font.ColorIndex
Case 3
If Not CopyRange Is Nothing Then
Set CopyRange = Union(CopyRange, EachCell.EntireRow)
Else
Set CopyRange = EachCell.EntireRow
End If

Case Else
If IsNull(EachCell.Font.ColorIndex) Then
'Your code here in lieu of msgbox
'to handle mixed colors
MsgBox EachCell.Address & " contains mixed colors"
End If
End Select

Next EachCell

CopyRange.Copy

 

[DavidH56]

Thank you again OssieMac,

Your code has absolutely resolved my problem. It does exactly what I
needed. Here it is in it's final version:

Dim LastRow As Long
Dim SearchRange As Range
Dim searchRow As Range
Dim CopyRange As Range
Dim EachCell As Range
Dim nSh As Worksheet
Dim sh As Worksheet

LastRow = Cells(rows.Count, "F").End(xlUp).Row

Set SearchRange = ActiveSheet.Range("C1:Q" & LastRow)

Set sh = ActiveSheet

For Each EachCell In SearchRange

Select Case EachCell.Font.ColorIndex
Case 3, Not vbBlack
If Not CopyRange Is Nothing Then
Set CopyRange = Union(CopyRange, EachCell.EntireRow)
Else
Set CopyRange = EachCell.EntireRow
End If

Case Else
If IsNull(EachCell.Font.ColorIndex) Then
'Your code here in lieu of msgbox
'to handle mixed colors
If Not CopyRange Is Nothing Then
Set CopyRange = Union(CopyRange, EachCell.EntireRow)
Else
Set CopyRange = EachCell.EntireRow
End If
End If
End Select


Select Case EachCell.Interior.ColorIndex
Case 3, 6, 8, 33
If Not CopyRange Is Nothing Then
Set CopyRange = Union(CopyRange, EachCell.EntireRow)
Else
Set CopyRange = EachCell.EntireRow
End If
End Select

Next EachCell

Again, thank you for your expertise.

 

[OssieMac]

Hello again David,

I have just realized that I have not been receiving email notifications of
replies to my posts on this forum and have had to do a search on my recent
posts to find them. Hense the late reply. (I've now reported the problem to
Microsoft so hopefully they will fix it.)

However, a couple of observations in your code example.

You should reverse the two lines of code where you assign the active sheet
to a variable and Set the SearchRange. You can then use the worksheet
variable when assigning the range to SearchRange like the following.

Set sh = ActiveSheet
Set SearchRange = sh.Range("C1:Q" & LastRow)

The other thing is to take care when using the color constants to identify a
color. You cannot mix ColorIndex and Color constants as you have done.
ColorIndex and color constants are quite different in VBA. I think that your
line
Case 3, Not vbBlack
should actually be
Case 3, Not xlColorIndexAutomatic

The ColorIndex for black is 1 while the Color Constant vbBlack value is zero.

The ColorIndex values are 1 to 56
plus
xlColorIndexAutomatic with a value of -4105 (when color is set to automatic)
xlColorIndexNone with a value of -4142
See help for more on these. It is highly likely that what you are assuming
is black is actually xlColorIndexAutomatic.

Demonstration:
Set an ActiveCell to font color Automatic and run the following code and
observe the values returned. ColorIndex constants do not match the color
values (or Color constants). ColorIndex constant for Black is 1 while color
value for black is zero (same as vbBlack constant). vbBlack refers to a Color
Constant not ColorIndex.

Sub testFontColor()
'Type anything into the ActiveCell and
'set the font color to Automatic.

MsgBox "ActiveCell.Font.Colorindex is " & _
ActiveCell.Font.ColorIndex & vbCrLf & _
"ActiveCell.Font.Color is " & _
ActiveCell.Font.Color
End Sub

Further demo:
Insert the following code into a blank workbook and it will return all of
the colors for the ColorIndex constants in column A. The row number
represents the ColorIndex. Note that 1 is black.

Column B has the font Colors set to the 8 Color Constant colors with their
constant values and the adjacent column C has the names of the Color
Constant. Note that the values of Colors do not match the values of
ColorIndex.

Sub ColorDemo()
Dim i As Long
'Following sets the interior colors to ColorIndex
'The row number is the ColorIndex for the specified color
'NOTE: Used ColorIndex not color
For i = 1 To 56
Cells(i, 1).Interior.ColorIndex = i
Next i

'Following sets fonts to Color Constants
'with constant value in colored font and
'name of constant adjacent.
'NOTE: Used Color not ColorIndex
Cells(1, 2).Font.Color = vbBlack
Cells(1, 2).Value = vbBlack
Cells(1, 3).Value = "vbBlack"

Cells(2, 2).Font.Color = vbRed
Cells(2, 2).Value = vbRed
Cells(2, 3).Value = "vbRed"

Cells(3, 2).Font.Color = vbGreen
Cells(3, 2).Value = vbGreen
Cells(3, 3).Value = "vbGreen"

Cells(4, 2).Font.Color = vbYellow
Cells(4, 2).Value = vbYellow
Cells(4, 3).Value = "vbYellow"

Cells(5, 2).Font.Color = vbBlue
Cells(5, 2).Value = vbBlue
Cells(5, 3).Value = "vbBlue"

Cells(6, 2).Font.Color = vbMagenta
Cells(6, 2).Value = vbMagenta
Cells(6, 3).Value = "vbMagenta"

Cells(7, 2).Font.Color = vbCyan
Cells(7, 2).Value = vbCyan
Cells(7, 3).Value = "vbCyan"

'Following cell set to black interior otherwise
'white font is not visible.
Cells(8, 2).Interior.Color = vbBlack
Cells(8, 2).Font.Color = vbWhite
Cells(8, 2).Value = vbWhite
Cells(8, 3).Value = "vbWhite"

End Sub