G
Guest
Here is my code so far.
Private Sub CommandButton1_Click()
Dim rng As Range, rng1 As Range
Dim cell As Range
Set rng = Range(Cells(1, "O"), Cells(Rows.Count, "O").End(xlUp))
For Each cell In rng
If cell.Font.ColorIndex = 6 Or cell.Font.ColorIndex = 3 Then
If rng1 Is Nothing Then
Set rng1 = cell
Else
Set rng1 = Union(rng1, cell)
End If
End If
Next cell
If Not rng1 Is Nothing Then
rng1.EntireRow.Copy Destination:= _
Worksheets("Sheet3").Cells(Rows.Count, 1).End(xlUp)
Else
MsgBox "No cells met criteria"
End If
This copys a row if the font in column O is red or yellow.
I am also trying to see if it has text in columns A or B and if there is no
contents, I want it to copy the cell above it.
For example:
A B -------------------------
O
5 1 1
6 1
7
8
red font
The code would then copy cells A5 & B6 to A8 & B8 on the other sheet
Private Sub CommandButton1_Click()
Dim rng As Range, rng1 As Range
Dim cell As Range
Set rng = Range(Cells(1, "O"), Cells(Rows.Count, "O").End(xlUp))
For Each cell In rng
If cell.Font.ColorIndex = 6 Or cell.Font.ColorIndex = 3 Then
If rng1 Is Nothing Then
Set rng1 = cell
Else
Set rng1 = Union(rng1, cell)
End If
End If
Next cell
If Not rng1 Is Nothing Then
rng1.EntireRow.Copy Destination:= _
Worksheets("Sheet3").Cells(Rows.Count, 1).End(xlUp)
Else
MsgBox "No cells met criteria"
End If
This copys a row if the font in column O is red or yellow.
I am also trying to see if it has text in columns A or B and if there is no
contents, I want it to copy the cell above it.
For example:
A B -------------------------
O
5 1 1
6 1
7
8
red font
The code would then copy cells A5 & B6 to A8 & B8 on the other sheet