Macro to copy and paste a range of data into a new sheet based on conditional formatting in another

[qplsn9]

I have this spreadsheet for our laboratory stock. Column U determines if an item needs reordered based on calculations on our quantity in stock and an ordering point determined by us. Basically, I want to copy and paste only the items (as well as quantities, units, etc.) to the sheet 3_Master PO Form but only if the cell in column U is red or yellow. I have about 700 lines of items that have this formatting and I want the macro to go through each one and copy and paste it over to the next sheet if it is red or yellow. How do I do this?

[#2 · Accepted solution]

@qplsn9 If you're conditional formatting rules are simply based on the cell value (ie: >0, Green; =0, Yellow; <0, Red), you could just use AutoFilter to filter the data by values less than or equal to 0, then copy and paste the results to the destination sheet. Alternatively, you could also filter by color; however, this would have to be done twice, as you can only filter by one color at a time.

To answer your question directly, you can loop through the range of cells and use the DisplayFormat.Interior.Color property to get the fill color set by conditional formatting; however, you will need to know the specific color codes that were used (ie: RGB(255, 235, 156) = Yellow; RGB(255, 199, 206) = Light Red). Based on the single screenshot provided, which is a very limited representation of what your actual data range might look like, the following is to be used as an example only for how this might be achieved:

Option Explicit

Sub CopyRecordsByDisplayFormat()

'Clear the previous output values
    Dim wsOutput As Worksheet
    Set wsOutput = ThisWorkbook.Sheets("3_Master PO Form")
    With wsOutput
        .Range("A1:U" & .Cells(.Rows.Count, 21).End(xlUp).Row).Offset(1).ClearContents
    End With

'Copy applicable rows from the inventory sheet to the output sheet
    Dim ws As Worksheet, rg As Range, lastRow As Long, rowId As Long, i As Long
    Set ws = ThisWorkbook.Sheets("2_LAB Inventory Master List")
    lastRow = ws.Cells(ws.Rows.Count, 21).End(xlUp).Row
    Set rg = ws.Range("A1:U" & lastRow)
    rowId = 2
    For i = 2 To lastRow
        Select Case rg.Cells(i, 21).DisplayFormat.Interior.Color
        ' if Yellow Fill OR Light Red Fill
            Case RGB(255, 235, 156), RGB(255, 199, 206)
                wsOutput.Cells(rowId, 1).Resize(, 21).Value = rg.Rows(i).Value
                rowId = rowId + 1
        End Select
    Next i

End Sub

Note: please adjust the sheet names, range references, column numbers and/or color codes to meet your needs. You've stated the output sheet is "3_Master PO Form", but in the screenshot provided it appears to be named "3_Master PO Request". Also, it was unclear to me which columns actually contain data (ie: column A and B appear to be blank), and which columns were to be included in the final output.

[#3]

This works, thank you! I fixed the errors in naming. How would I make it so that it transfers only columns A:F, N:O, and U to the 3_Master PO Request sheet without any blank columns in between?

[#4]

@qplsn9 To transfer the specified columns (9 in total) to columns A:I in the output worksheet, try the following modifications:

Option Explicit

Sub CopyRecordsByDisplayFormat()

'Clear the previous output values
    Dim wsOutput As Worksheet
    Set wsOutput = ThisWorkbook.Sheets("3_Master PO Request")
    With wsOutput
        .Range("A1:I" & .Cells(.Rows.Count, 9).End(xlUp).Row).Offset(1).ClearContents
    End With

'Copy applicable rows from the inventory sheet to the output sheet
    Dim ws As Worksheet, rg As Range, lastRow As Long, rowId As Long, i As Long
    Set ws = ThisWorkbook.Sheets("2_LAB Inventory Master List")
    lastRow = ws.Cells(ws.Rows.Count, 21).End(xlUp).Row
    Set rg = ws.Range("A1:U" & lastRow)
    rowId = 2
    For i = 2 To lastRow
        Select Case rg.Cells(i, 21).DisplayFormat.Interior.Color
        ' if Yellow Fill OR Light Red Fill
            Case RGB(255, 235, 156), RGB(255, 199, 206)
                With wsOutput
                ' columns A:F = A:F
                    .Cells(rowId, 1).Resize(, 6).Value = rg.Cells(i, 1).Resize(, 6).Value
                ' columns G:H = N:O
                    .Cells(rowId, 7).Resize(, 2).Value = rg.Cells(i, 14).Resize(, 2).Value
                ' column I = U
                    .Cells(rowId, 9).Value = rg.Cells(i, 21).Value
                End With
                rowId = rowId + 1
        End Select
    Next i

End Sub