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-

CodeBreakers</SPAN>

Globetrotters</SPAN>

RBivr</SPAN>

Stairway to Hygiene</SPAN>

Team Mastermind</SPAN>

The Dial Tones</SPAN>

<TBODY>
</TBODY><COLGROUP><COL></COLGROUP>

Column</SPAN>	Header Label</SPAN>
A</SPAN>	Team
B</SPAN>	Title</SPAN>
C</SPAN>	Epic</SPAN>
D</SPAN>	Goals</SPAN>
E</SPAN>	Production Deployment Date</SPAN>
F</SPAN>	Release Name</SPAN>
G</SPAN>	Sprint</SPAN>
H</SPAN>	Status </SPAN>

<TBODY>
</TBODY><COLGROUP><COL><COL></COLGROUP>

 

[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