The following macro should do it for you.
It delete data from Sheet2 and create sheets if they don't exist.
Public Sub Transfer_Data()
Dim LR As Long
Dim wsSheet As Worksheet
'Make sure we are on Sheet2
Sheets("Sheet2").Range("A1").Select
'Activate Autofilter mode if not ON
If Not Worksheets("Sheet2").FilterMode Then
Selection.AutoFilter
End If
'Loop till there is no more data in range(A2)
Do While Range("A2") <> ""
'Check if sheet exists
On Error Resume Next
Set wsSheet = Sheets(Range("A2").Value)
On Error GoTo 0
If wsSheet Is Nothing Then 'If sheet does not exist, create and name it
Sheets.Add
ActiveSheet.Name = Sheets("Sheet2").Range("A2").Value
'Copy Titles from row 1 of Sheet2
Sheets("Sheet2").Range("A1:F1").Copy
ActiveSheet.Range("A1").PasteSpecial
Sheets("Sheet2").Select
' Else
' Set wsSheet = Nothing
End If
'END checking and/or creating new sheet
'Determine last row of data
LR = Range("A" & Rows.Count).End(xlUp).Row
'Filter data
ActiveSheet.Range("$A$1:$F$" & LR).AutoFilter Field:=1, Criteria1:=Range("A2")
LR = Range("A" & Rows.Count).End(xlUp).Row
'Copy only visible rows
Range("A2:F" & LR).SpecialCells(xlCellTypeVisible).Copy
Sheets(Range("A2").Value).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial
Range("A2:F" & LR).SpecialCells(xlCellTypeVisible).Select
'Delete copied rows from Sheet2
Selection.EntireRow.Delete
'Deactivate autofilter so all data is showing
Selection.AutoFilter
'Activate the first cell of titles prior to activate autofilter
Range("A1").Select
'Reactivate autofilter for the next loop
Selection.AutoFilter
Loop
End Sub
Bookmarks