Create New sheet and copy appropriate data to new sheet

[K]

Hi all, I have two sheets in workbook. First Sheet names is "Data"
and the second Sheet names is "Template". In Sheet("Data") I have
below data.

A B C D…….col
Record1 LC1 1256 sus
Record1 LC1 1453 suv
Record1 LC1 1566 sut
Record2 LD1 1256 sus
Record2 LD1 1453 suv
Record2 LD1 1566 sut
Record3 LE1 1256 sus
Record3 LE1 1453 suv
Record3 LE1 1566 sut

I need macro on a button in Sheet("Data") which should copy Sheet
("Template") by looking at each unique value in column B of above data
and give the new copied Sheet the unique value name. For example
according to above data macro should copy Sheet("Template") three time
and name them LC1 , LD1 , LE1. While coping Sheet("Template"), macro
should also copy data of column A to D which is in same row of unique
value of column B into unique value sheet. For example

A B C D…….col
Record1 LC1 1256 sus
Record1 LC1 1453 suv
Record1 LC1 1566 sut
Above data should be copied in Sheet("LC1") in range A2

A B C D…….col
Record2 LD1 1256 sus
Record2 LD1 1453 suv
Record2 LD1 1566 sut
Above data should be copied in Sheet("LD1") in range A2

A B C D…….col
Record3 LE1 1256 sus
Record3 LE1 1453 suv
Record3 LE1 1566 sut
Above data should be copied in Sheet("LE1") in range A2

I hope I was able to explain my question. Please can any friend help
me.

 

[Patrick Molloy]

place this in a standard module (ALT+F11 INSERT/MODULE)

Option Explicit
Dim rw As Long
Sub Maib()
Dim ws As Worksheet
Dim target As Range
With Worksheets("data")
.Cells.Sort Range("B1")
Set target = .Range("B1")
Do Until target = ""
Set ws = GetSheet(target.Value)
.Rows(target.Row).Copy
ws.Rows(rw).PasteSpecial xlAll
Set target = target.Offset(1)
Loop
End With
End Sub
Function GetSheet(sName As String) As Worksheet
On Error Resume Next
Set GetSheet = Worksheets(sName)
If Err.Number <> 0 Then
Worksheets("template").Copy after:=Worksheets(Worksheets.Count)
Set GetSheet = Worksheets(Worksheets.Count)
GetSheet.Name = sName
rw = 0 'initialise
End If
rw = rw + 1