如果单元格在Excel中为红色/绿色/黄色，则复制并粘贴整行

Question

I have a table with values based on monthly based and product in 1st column as shown below (Say "sheet1"). This table has conditional formatting applied to highlight cell colors red/yellow/green based on target. So, I want to take only specific month(current month- May) column and want VBA to check, if any cell in that column is Red, select that entire row and copy past it into another sheet for example "Sheet2" with headers.

Product   =  Target   Feb Mar Apr May
Wood     >=    5      10  10  10  10
wood     >=    5      28  28  28  28
Tree     >=   12      30  45  60  68
plastic  >=   45      50  50  50  50
tree     >=   50      50  50  50  50
iron     >=   100     64  75  75  80

The values will change monthly and even sometimes target, so the coloring can be totally green/yellow/red sometimes. So, I want to automate this process using VBA, to go and check on "Sheet1" every month and pull any rows which has red cell highlighted for that month. OR even a button function could also help, so I can assign this macro to a button, this action should be done by clicking the button. Even it should also clear all rows from earlier month in Sheet2, which might have highlighted in last month but not in this month.

I tried, different ways to do this, its not recognizing the cell color. When I use the random/regular cell out of table and fill with red color and use find(ctrl+f) popup box to highlight using color format, it is working but its not taking the cells which has conditional formatting in a table. So, I don't know if there is a way to identify all the cells in the table which is highlighted in red using VBA.

Answer 1

INPUT (IN WORKSHEET1):

OUTPUT (IN WORKSHEET2):

    Sub newnew()

declaring the worksheets, Sheet2 and Sheet3 should be changed to match your sheet names

    Dim ws As Worksheet
        Set ws = Sheets("Sheet2")

    Dim wsTwo As Worksheet
       Set wsTwo = Sheets("Sheet3")

clearing out previous data in wsTwo

    wsTwo.Cells.Clear

finding the last row and column for ws with data inside

    Dim lastRow As Integer
        lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    Dim lastColumn As Integer
        lastColumn = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column

we are setting up the header here

    ws.Range("A1:F1").Copy
    wsTwo.Range("A1:F1").PasteSpecial xlPasteAll
    Application.CutCopyMode = False

beginning our loop from the last row and moving upwards till we hit row 2. We are checking if rowNum and lastColumn display format interior color is red. If it is we are taking that range, copying it, then pasting it in wsTwo. Note that we have that rowCounter which we set before entering the for loop. we will use that as a placeholder, incrementing every time that we paste in ws two, so that we don't paste over data we just pasted.

     Dim rowCounterWsTwo As Integer
         rowCounterWsTwo = 2

    For rowNum = lastRow To 2 Step -1
            If Cells(rowNum, lastColumn).DisplayFormat.Interior.Color = vbRed = vbRed Then
                ws.Range(Cells(rowNum, 1), Cells(rowNum, lastColumn)).Copy
                wsTwo.Range("A2:F2").Insert
                Application.CutCopyMode = False
                rowCounterWsTwo = rowCounterWsTwo + 1
            End If
    Next rowNum

End Sub