Return Rows only containing Non Red Cells

[dlevitt]

I'm trying to copy information from one worksheet to another. When the code below finds red colored text in column A in the srcWs (source worksheet) it copies the red color text and the preceding 6 rows into the dstWS (Destination worksheet).

I need to modify this code to only copy the the first instance of red colored text in Column A srcWs (source worksheet) plus the preceding 6 rows containing only black text and skip over (not copy) any additional red colored text. This information would be copied to the dstWS (Destination worksheet) and the code would cycle through the entire Source worksheet until completed.

Referring to my sample below you will see that row 6 contains red colored text. I want my code below to skip over this red colored text and copy row 8 backward 6 rows but skip row 6 because it contains red colored text. I then want the code to repeat this process for every instance of red colored text in column A.

Time MPIDInside Bid Inside Bid Tick
Row 1 7:43:13 C SCHB 50 1 77 1 (black colored text)
Row 2 7:43:13 C SCHB 50 1 77 1 (black colored text)
Row 3 7:46:10 C PRUS 51 1 57.5 1 (black colored text)
Row 4 7:46:11 C PRUS 51 1 58 1 (black colored text)
Row 5 7:46:14 C PRUS 51 1 58.5 1 (black colored text)
Row 6 7:46:14 C PRUS 51 1 59 1 (red colored text)
Row 7 7:46:16 C PRUS 51 1 59.5 1 (black colored text)
Row 8 7:46:16 C PRUS 51 1 60 1 (red colored text)


Sub CopyRedCells()
Dim srcWs As Worksheet, dstWs As Worksheet
Dim Cell As Range, Rng As Range, dstRng As Range
Dim lastRow As Long

Set srcWs = Sheets("MM_OSTK_01-12-2005AM")
Set dstWs = Sheets("Sheet4") 'change to your destination worksheet
lastRow = srcWs.Range("A" & Cells.Rows.Count).End(xlUp).Row
Set Rng = srcWs.Range("A2:A" & lastRow)

For Each Cell In Rng
With Cell.Font
If (.Color = vbRed And .Name = "Arial") And (Cell.Value <> "Time") Then
If dstWs.Range("A" & Cells.Rows.Count).End(xlUp).Row < 5 Then
Set dstRng = dstWs.Range("A5")
Else
Set dstRng = dstWs.Range("A" & Cells.Rows.Count).End(xlUp).Offset(2)

End If
srcWs.Rows(Cell.Row & ":" & Cell.Row - 6).Copy dstRng
End If
End With
Next Cell
End Sub


Thanks you input is greatly appreciated.

David

 

[Datsmart]

Your code worked on a quick sample page I setup.

How are your cell fonts colored?
It won't work if you are using conditional formatting.
You will have to use the conditions that CF uses in your code.

 

[dlevitt]

Hi John:

Yes the code works in that it will find each red colored cell in Column A and then copy the red colored text and the 6 rows above to a new worksheet. The code continues to perform this task until it reads all rows in the source worksheet. My issue is as follows:

I need for the code to loop through the source worksheet and find the red colored text in Column A but I want the code, when it read and then copies the 6 rows above the red colored text to skip over (not copy) any additonal rows with red colored text.

So if the source in column A looks like this

Black text
Black text (2nd loop through code is not copied but should be copied)
Black text (2nd loop through code is copied)
Black text (2nd loop through code is copied)
Black text (2nd loop through code is copied)
Black text (2nd loop through code is copied)
Black text (2nd loop through code is copied)
Red text (on 2nd loop through code should not be copied but presently is being copied)
Red text (2nd loop should be copied)

I want the code to see the first occurrence of Red Text and then copy it and the next 6 rows but skip over any other red text in column A. So using my example above. On the 2nd loop through the code, as presently written, the code copies the last red text but also copies the red text above and instead of copying 6 black text only copies 5 black text because the program is counting the first red text.

I have thousands of rows with in which Column A has some red text and some black text and again the purpose of the code should be to loop through every single row in column A and only copy the first occurrence of red text and the next 6 occurrences of black text above.

The final destination worksheet should all look like this.

Black text
Black text
Black text
Black text
Black text
Black text
Red text

Black text
Black text
Black text
Black text
Black text
Black text
Red text

Black text
Black text
Black text
Black text
Black text
Black text
Red text


Sorry for the long explanation but I have a huge project and I'm out of my league.

Thanks,

David

 

[Datsmart]

This code does what I think you are asking.

Sub CopyRedCells()
Dim srcWs As Worksheet, dstWs As Worksheet
Dim Cell As Range, Rng As Range, Rng2 As Range
Dim lastRow As Long
Dim RedFonts As Integer
Dim e As Range
Dim DRow As Integer
Set srcWs = Sheets("MM_OSTK_01-12-2005AM")
Set dstWs = Sheets("Sheet4") 'change to your destination worksheet
lastRow = srcWs.Range("A" & Cells.Rows.Count).End(xlUp).Row
Set Rng = srcWs.Range("A2:A" & lastRow)

    For Each Cell In Rng
        cr = Cell.Row 'Variable for Current Row number
        With Cell.Font
            If (.Color = vbRed And .Name = "Arial") And (Cell.Value <> "Time") Then
                If dstWs.Range("A" & Cells.Rows.Count).End(xlUp).Row < 5 Then
                    DRow = 5
                Else
                    DRow = dstWs.Range("A" & Cells.Rows.Count).End(xlUp).Row
                End If
    DRow = DRow + 1
'=================================
    'Find out how many red fonts exist in current range of 6 rows
    RedFonts = 0
        For Each e In Range("A" & cr - 6 & ":A" & cr)
            If e.Font.Color = vbRed Then RedFonts = RedFonts + 1
        Next e
    RedFonts = RedFonts + 5 'Add count of RedFonts to Rng2
'=================================
            Set Rng2 = Range("A" & cr - RedFonts & ":A" & cr) 'Variable Range for group of 6 rows
                For Each c In Rng2
                    If c.Font.Color <> vbRed Then
                        cr2 = c.Row
                        srcWs.Rows(cr2 & ":" & cr2).Copy dstWs.Range("A" & DRow)
                        DRow = DRow + 1
                    End If
                    If c.Row = cr Then
                        'now copy Red Font Row
                        srcWs.Rows(cr & ":" & cr).Copy dstWs.Range("A" & DRow)
                    End If
                Next c
            End If
        End With
    Next Cell
End Sub

 

[dlevitt]

John:

I ran your code again without the my column headings and it worked perfectly. Thank you much appreciated.

David

 

[dlevitt]

Hi John:

I'm finding with your code that if I have 3 or more red cells sequentially in column A then your code is not parsing the data the way I had hoped.

To briefly recap.

I have thousands of text data in column A. Sometimes 35,000 rows. Contained within these rows are both black text and red text. I basically laid one worksheet on top of another and sorted by column A. The red text represents data coming from one worksheet and the black text represents data coming from a 2nd worksheet. Both worksheets are then sorted by column A to put the Column A called "Time" into a logical time sequence.

I need to start at the top of Column A and read down until I find the first occurrence of a red colored cell. Then I need to copy this red colored cell and the preceding 6 rows above containing black text to a new worksheet. If any of the rows above contain red cells I need to skip over them. Clearly this will not happen on the first occurrence but on subsequent occurrences it is not only likely but highly probably that I can have from 2 to 10 red colored cells in column A one after another. Your code is having trouble when it is coming across more than 2 red cells sequentially.

Your code is almost there and I really appreciate your help. I would truly appreciate any further input or suggests to make this code work. Does reading the data in batches of 6 rows make sense. Would it work better to just grab the address of the first occurence of each red cell and then read up skip over any additional red cells copy 6 black cells and then loop back to the next red cell address and start the process again.

Thank,

David

 

[Datsmart]

This revised code works with my test data.
Each red text cell from the source sheet will be pasted to sheet Sheet4 with 6 black text values above it. In cases where 6 black text cells are not available, (if red text cell on source sheet does not have 6 black text values above it), fewer will be copied.

Sub CopyRedCells()
Dim srcWs As Worksheet, dstWs As Worksheet
Dim Cell As Range, Rng As Range, Rng2 As Range
Dim lastRow As Long
Dim RedFonts As Integer
Dim e As Range
Dim cr As Integer, cr2 As Integer, cr3 As Integer
Dim DRow As Integer
Set srcWs = Sheets("MM_OSTK_01-12-2005AM")
Set dstWs = Sheets("Sheet4") 'change to your destination worksheet
lastRow = srcWs.Range("A" & Cells.Rows.Count).End(xlUp).Row
Set Rng = srcWs.Range("A2:A" & lastRow)
'Sheets("Sheet4").Cells.ClearContents

    For Each Cell In Rng
        cr = Cell.Row 'Variable for Current Row number
        With Cell.Font
            If (.Color = vbRed And .Name = "Arial") And (Cell.Value <> "Time") Then
                If dstWs.Range("A" & Cells.Rows.Count).End(xlUp).Row < 5 Then
                    DRow = 5
                Else
                    DRow = dstWs.Range("A" & Cells.Rows.Count).End(xlUp).Row
                End If
        DRow = DRow + 1
'=================================
    'Loop to get row number (cr3) for top of range
    nr = 0
    cr3 = cr - 6
    Do
        If cr3 < 1 Then cr3 = 1
        For Each e In srcWs.Range(Cells(cr3, 1), Cells(cr, 1))
            If Not e.Font.Color = vbRed Then nr = nr + 1
        Next e
        If nr < 6 Then 'If not enough non-red cells, increase range
            cr3 = cr3 - 1
            nr = 0
        End If
        If cr3 < 1 Then
            cr3 = 1
            Exit Do
        End If
    Loop Until nr > 5
'=================================
            Set Rng2 = srcWs.Range("A" & cr3 & ":A" & cr)  'Variable Range for group of 6 rows
                For Each c In Rng2
                    If c.Font.Color <> vbRed Then
                        cr2 = c.Row
                        srcWs.Rows(cr2 & ":" & cr2).Copy dstWs.Range("A" & DRow)
                        DRow = DRow + 1
                    End If
                    If c.Row = cr Then
                        'now copy Red Font Row
                        srcWs.Rows(cr & ":" & cr).Copy dstWs.Range("A" & DRow)
                    End If
                Next c
            End If
        End With
    Next Cell
'Sheets("Sheet4").Select
End Sub

 

[dlevitt]

Hi John:

This code works perfectly.

I cannot thank you enough for taking the time to help me with this, truly, from the bottom of my heart, thanks.

David