Results 1 to 8 of 8

Thread: Return Rows only containing Non Red Cells
Thanks Thanks: 0 Likes Likes: 0

  1. #1
    Board Regular
    Join Date
    Oct 2005
    Posts
    59
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Return Rows only containing Non Red Cells

    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

  2. #2
    Board Regular Datsmart's Avatar
    Join Date
    Jun 2003
    Location
    Olympia
    Posts
    7,985
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Return Rows only containing Non Red Cells

    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.
    John

  3. #3
    Board Regular
    Join Date
    Oct 2005
    Posts
    59
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Return Rows only containing Non Red Cells

    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

  4. #4
    Board Regular Datsmart's Avatar
    Join Date
    Jun 2003
    Location
    Olympia
    Posts
    7,985
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Return Rows only containing Non Red Cells

    This code does what I think you are asking.
    Code:
    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
    John

  5. #5
    Board Regular
    Join Date
    Oct 2005
    Posts
    59
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Return Rows only containing Non Red Cells

    John:

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

    David

  6. #6
    Board Regular
    Join Date
    Oct 2005
    Posts
    59
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Return Rows only containing Non Red Cells

    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

  7. #7
    Board Regular Datsmart's Avatar
    Join Date
    Jun 2003
    Location
    Olympia
    Posts
    7,985
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Return Rows only containing Non Red Cells

    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.
    Code:
    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
    John

  8. #8
    Board Regular
    Join Date
    Oct 2005
    Posts
    59
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Return Rows only containing Non Red Cells

    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

Some videos you may like

User Tag List

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •