VBA - Identify rows by value and copy and paste into new tab

[JetSetDrive]

I need assistance writing a code that will allow me to identify all rows that have a value of "Yellow" in column B. I then need to copy only the identified cells over to a new tab and label the new tab "Yellow"

I appreciate the help

Thank you.

 

[My Aswer Is This]

Try this:

Sub Filter_Me_Please()
'Modified  7/26/2019  9:12:59 PM  EDT
Application.ScreenUpdating = False
Dim lastrow As Long
Dim c As Long
Dim s As Variant
Dim ans As String
ans = ActiveSheet.Name
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Yellow"
c = 2 ' Column Number Modify this to your need
s = "Yellow" 'Search Value Modify to your need
lastrow = Sheets(ans).Cells(Rows.Count, c).End(xlUp).Row
With Sheets(ans).Cells(1, c).Resize(lastrow)
    .AutoFilter 1, s
    counter = .Columns(c).SpecialCells(xlCellTypeVisible).Count
    If counter > 1 Then
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets("Yellow").Rows(1)
    Else
        MsgBox "No values found"
    End If
    .AutoFilter
End With
Application.ScreenUpdating = True
End Sub

 

[JetSetDrive]

Is there a way to keep the same header from the first tab?

 

[My Aswer Is This]

Assuming your header is Row(1)
Then try this:

Sub Filter_Me_Please()
'Modified  7/26/2019  9:44:36 PM  EDT
Application.ScreenUpdating = False
Dim lastrow As Long
Dim c As Long
Dim s As Variant
Dim ans As String
ans = ActiveSheet.Name
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Yellow"
c = 2 ' Column Number Modify this to your need
s = "Yellow" 'Search Value Modify to your need
lastrow = Sheets(ans).Cells(Rows.Count, c).End(xlUp).Row
With Sheets(ans).Cells(1, c).Resize(lastrow)
    .AutoFilter 1, s
    counter = .Columns(c).SpecialCells(xlCellTypeVisible).Count
    If counter > 1 Then
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets("Yellow").Rows(2)
        Sheets(ans).Rows(1).Copy Sheets("Yellow").Rows(1)
    Else
        MsgBox "No values found"
    End If
    .AutoFilter
End With
Application.ScreenUpdating = True
End Sub

 

[JetSetDrive]

Thank you

 

[Peter_SSs]

Here is another approach that you could try in a copy of your workbook.

Sub Copy_Rows()
  Dim wsOld As Worksheet, wsNew As Worksheet
  
  Set wsOld = ActiveSheet
  Sheets.Add(After:=wsOld).Name = "Yellow"
  Set wsNew = Sheets(wsOld.Index + 1)
  With wsNew
    .Range("A1:A2").Value = Application.Transpose(Array(wsOld.Range("B1").Value, "Yellow"))
    wsOld.UsedRange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("A1:A2"), CopyToRange:=.Range("B1"), Unique:=False
    .Columns(1).Delete
  End With
End Sub

 

[My Aswer Is This]

Yes there are always 20 different ways to do everthing with Excel.

Here is another approach that you could try in a copy of your workbook.

Sub Copy_Rows()
  Dim wsOld As Worksheet, wsNew As Worksheet
  
  Set wsOld = ActiveSheet
  Sheets.Add(After:=wsOld).Name = "Yellow"
  Set wsNew = Sheets(wsOld.Index + 1)
  With wsNew
    .Range("A1:A2").Value = Application.Transpose(Array(wsOld.Range("B1").Value, "Yellow"))
    wsOld.UsedRange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("A1:A2"), CopyToRange:=.Range("B1"), Unique:=False
    .Columns(1).Delete
  End With
End Sub

 

[Peter_SSs]

Yes there are always 20 different ways to do everthing with Excel.

Any reason the OP should only get offered one of them?

BTW, our codes do not do exactly the same thing. Yours may well do what the OP wants and mine might not. It could be the other way around, or they might both do what the OP wants - depends on the detail of the data and the requirement.
Further reason to offer choice.

 

[DanteAmor]

Just another way.

Sub Copy_Yellow()
  Dim sh As Worksheet
  Set sh = ActiveSheet
  sh.Range("A1").CurrentRegion.AutoFilter 2, "Yellow"
  Sheets.Add(, Sheets(Sheets.Count)).Name = "Yellow"
  sh.AutoFilter.Range.EntireRow.Copy Range("A1")
  sh.ShowAllData
End Sub