Macro to copy row based on color

Topic

New Reply

I am in need of help with VBA code that will copy all rows where cells in column A is red and then paste the entire row into a new worksheet.

This one is above my pay grade.

Can anyone help?

JG

Reply | Quote

Replies

The following will look at the cells in col A of the activeworksheet and copy them to the same row in a new worksheet:

Code:

Option Explicit
Sub CopyRedRowsAsIs()
  Dim wks As Worksheet
  Dim wNew As Worksheet
  Dim lRow As Long
  Dim x As Long
  
  Set wks = ActiveSheet
  lRow = wks.Cells.SpecialCells(xlCellTypeLastCell).Row
  Set wNew = Worksheets.Add
  For x = 1 To lRow
    If wks.Cells(x, 1).Interior.Color = vbRed Then
      wks.Cells(x, 1).EntireRow.Copy wNew.Cells(x, 1)
    End If
  Next
End Sub

If you want to not keep the same row as the original, but group them together in the new worksheet, the following code will do that

Code:

Option Explicit
Sub CopyRedRowsGroup()
  Dim wks As Worksheet
  Dim wNew As Worksheet
  Dim lRow As Long
  Dim lNewRow As Long
  Dim x As Long
  
  Set wks = ActiveSheet
 lRow = wks.Cells.SpecialCells(xlCellTypeLastCell).Row
  Set wNew = Worksheets.Add
  lNewRow = 1
  For x = 1 To lRow
    If wks.Cells(x, 1).Interior.Color = vbRed Then
      wks.Cells(x, 1).EntireRow.Copy wNew.Cells(lNewRow, 1)
      lNewRow = lNewRow + 1
    End If
  Next
End Sub

If you want something different, you will have to be more specific…

Steve

Reply | Quote

The following will look at the cells in col A of the activeworksheet and copy them to the same row in a new worksheet:

Code:

Option Explicit
Sub CopyRedRowsAsIs()
  Dim wks As Worksheet
  Dim wNew As Worksheet
  Dim lRow As Long
  Dim x As Long
  
  Set wks = ActiveSheet
  lRow = wks.Cells.SpecialCells(xlCellTypeLastCell).Row
  Set wNew = Worksheets.Add
  For x = 1 To lRow
    If wks.Cells(x, 1).Interior.Color = vbRed Then
      wks.Cells(x, 1).EntireRow.Copy wNew.Cells(x, 1)
    End If
  Next
End Sub

If you want to not keep the same row as the original, but group them together in the new worksheet, the following code will do that

Code:

Option Explicit
Sub CopyRedRowsGroup()
  Dim wks As Worksheet
  Dim wNew As Worksheet
  Dim lRow As Long
  Dim lNewRow As Long
  Dim x As Long
  
  Set wks = ActiveSheet
 lRow = wks.Cells.SpecialCells(xlCellTypeLastCell).Row
  Set wNew = Worksheets.Add
  lNewRow = 1
  For x = 1 To lRow
    If wks.Cells(x, 1).Interior.Color = vbRed Then
      wks.Cells(x, 1).EntireRow.Copy wNew.Cells(lNewRow, 1)
      lNewRow = lNewRow + 1
    End If
  Next
End Sub

If you want something different, you will have to be more specific…

Steve

This macro works well for my needs but I have tried to modify it in order to look for at more than one column but I have not been successful… How would I need to modify this macro (CopyRedRowsGroup) in order to look at column A to Z? Thank you in advance!

Reply | Quote