Specific range of data copy from one sheet to another sheets.

Option Explicit


Sub CreateSheets()


    Dim Cell    As Range
    Dim RngBeg  As Range
    Dim RngEnd  As Range
    Dim Wks     As Worksheet


        Set RngBeg = Worksheets("Master").Range("A2")
        Set RngEnd = Worksheets("Master").Cells(Rows.Count, "A").End(xlUp)


        ' Exit if the list is empty.
        If RngEnd.Row < RngBeg.Row Then Exit Sub
Application.ScreenUpdating = False
        For Each Cell In Worksheets("Master").Range(RngBeg, RngEnd)
            On Error Resume Next
                ' No error means the worksheet exists.
                Set Wks = Worksheets(Cell.Value)


                ' Add a new worksheet and name it.
                If Err <> 0 Then
                    Set Wks = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                    Wks.Name = Cell.Value
                End If
            On Error GoTo 0
        Next Cell
Application.ScreenUpdating = True
MakeHeaders
End Sub


Sub MakeHeaders()
Dim srcSheet As String
Dim dst As Integer
srcSheet = "Master"
Application.ScreenUpdating = False
For dst = 1 To Sheets.Count
    If Sheets(dst).Name <> srcSheet Then
    Sheets(srcSheet).Rows("1:1").Copy
    Sheets(dst).Activate
    Sheets(dst).Range("A1").PasteSpecial xlPasteValues
    'ActiveSheet.PasteSpecial xlPasteValues
    Sheets(dst).Range("A1").Select
    End If
Next
Application.ScreenUpdating = True
CopyData
End Sub


Sub CopyData()
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
On Error GoTo M
Lastrow = Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Row
Dim ans As String
    For i = 2 To Lastrow
    ans = Sheets("Master").Cells(i, 1).Value
        Sheets("Master").Rows(i).Copy Sheets(ans).Rows(Sheets(ans).Cells(Rows.Count, "A").End(xlUp).Row + 1)
    Next
Application.ScreenUpdating = True


Sheets("Master").Activate
Sheets("Master").Range("A1").Select






Exit Sub


M:
MsgBox "No such sheet as  " & ans & " exist"
Application.ScreenUpdating = True


End Sub

Sub ExplodeData()
Dim lr As Long
Dim ws As Worksheet
Dim vcol As Integer
Dim i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' *** Adjust the next three instructions to your situation:   '
'     vcol is the Total Number of Columns                     '
'     ws should show the name of your Data Worksheet          '
'     title should show the columns from your Data worksheet  '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


'''''''''''''''''''''''''
vcol = 8                '   Total Number of Columns
Set ws = Sheets("Data") '   Define the Source Worksheet
title = "A1:H1"         '   Define the Headers Range
'''''''''''''''''''''''''


Application.ScreenUpdating = False
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Cells(1, Application.Columns.Count).End(xlToLeft).Column + 1
ws.Cells(1, icol) = "Unique"


  For i = 2 To lr
  On Error Resume Next
    If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
       ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
    End If
  Next i
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
    For i = 2 To UBound(myarr)
      ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
        If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
          Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
        Else
          Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
        End If
      ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
      Sheets(myarr(i) & "").Columns.AutoFit
    Next i
ws.AutoFilterMode = False
ws.Activate
MsgBox " DONE ... !!! "
End Sub