VBA / Macro Copy and Paste Rows Based upon Values

[swolford]

I want to create a worksheet and copy and paste rows with a specific value in Column A to a worksheet named for the value. The new sheet should have same header as in Sheet1

Possible Values-[TABLE="width: 132"]
<TBODY>[TR]
[TD]CodeBreakers</SPAN>[/TD]
[/TR]
[TR]
[TD]Globetrotters</SPAN>[/TD]
[/TR]
[TR]
[TD]RBivr</SPAN>[/TD]
[/TR]
[TR]
[TD]Stairway to Hygiene</SPAN>[/TD]
[/TR]
[TR]
[TD]Team Mastermind</SPAN>[/TD]
[/TR]
[TR]
[TD]The Dial Tones</SPAN>[/TD]
[/TR]
</TBODY><COLGROUP><COL></COLGROUP>[/TABLE]

[TABLE="width: 227"]
<TBODY>[TR]
[TD]Column</SPAN>[/TD]
[TD]Header Label</SPAN>[/TD]
[/TR]
[TR]
[TD]A</SPAN>[/TD]
[TD]Team[/TD]
[/TR]
[TR]
[TD]B</SPAN>[/TD]
[TD]Title</SPAN>[/TD]
[/TR]
[TR]
[TD]C</SPAN>[/TD]
[TD]Epic</SPAN>[/TD]
[/TR]
[TR]
[TD]D</SPAN>[/TD]
[TD]Goals</SPAN>[/TD]
[/TR]
[TR]
[TD]E</SPAN>[/TD]
[TD]Production Deployment Date</SPAN>[/TD]
[/TR]
[TR]
[TD]F</SPAN>[/TD]
[TD]Release Name</SPAN>[/TD]
[/TR]
[TR]
[TD]G</SPAN>[/TD]
[TD]Sprint</SPAN>[/TD]
[/TR]
[TR]
[TD]H</SPAN>[/TD]
[TD]Status
</SPAN>[/TD]
[/TR]
</TBODY><COLGROUP><COL><COL></COLGROUP>[/TABLE]

 

[ParamRay]

Sub Test()

Dim NewSheet As Worksheet
Dim WorkRange As Range
Dim Cell As Range
Dim Txt As String
Dim Matches As Long
Dim Match() As Long
Dim i As Long, j As Long

With Worksheets("Sheet1")
    Set WorkRange = Intersect(.Range("A:A"), .UsedRange)
End With

Txt = "CodeBreakers" 'the text you're looking for in column A
Matches = 0

For Each Cell In WorkRange
    If Cell.Row <> 1 And Cell.Value = Txt Then
        Matches = Matches + 1
        ReDim Preserve Match(1 To Matches)
        Match(Matches) = Cell.Row
    End If
Next Cell

Application.DisplayAlerts = False

If Matches > 0 Then
    On Error Resume Next
    Worksheets(Txt).Delete
    On Error GoTo 0
    Set NewSheet = Worksheets.Add
    With NewSheet
        .Name = Txt
        .Range("A1:H1").Value = Worksheets("Sheet1").Range("A1:H1").Value
        For i = 2 To Matches + 1
            For j = 1 To 8
                .Cells(i, j).Value = Worksheets("Sheet1").Cells(Match(i - 1), j).Value
            Next j
        Next i
    End With
End If

Application.DisplayAlerts = True

End Sub