Excel VBA: Create new worksheets upon a column

[YCCYCCYCCYCC]

Hello,

I would like to create multiple worksheets in the same workbook using one column as the deciding point:

For example (the following example is from worksheet named "Master". Then I will have another 3 worksheet for each individual, named "Adam", "Eric", "John". In total, I will have 4 worksheets which have Column Name and Column Location in each worksheet):
Please help!!!! Thanks!

Name	Location
Adam	NY
Adam	CA
Adam	MA
Eric	MA
Eric	NY
Eric	CT
Eric	FL
Eric	DC
John	DC
John	AK
John	WA

<colgroup><col width="64" span="2" style="width:48pt"> </colgroup><tbody>
</tbody>

 

[nuked]

There's probably a much easier way than this:

Sub CreateSheets()
Dim rng As Range
Dim cel As Range
Dim wks As Worksheet
Dim wksNew As Worksheet
Dim bFlag As Boolean
Set rng = Worksheets(1).Range("A1:A" & usedrange.rows.count) 'change this to suit your range of names
For Each cel In rng
    
    bFlag = False
    
    For Each wks In ThisWorkbook.Worksheets
    
        If wks.Name = cel Then
            bFlag = True: Exit For
        End If
        
    Next wks
    
     If Not bFlag Then
        Set wksNew = ThisWorkbook.Worksheets.Add
        wksNew.Name = cel
        Set wksNew = Nothing
     End If
    
       
Next cel
End Sub

 

[YCCYCCYCCYCC]

This is what I did...it did create worksheets using different name (Adam, Eric, John). But it's empty in each sheet....How can I get copy the data from the Master sheet to each worksheet? So that John worksheet will contain only data associates with John and etc.

Here is what I used. Thanks!

Sub CreateSheets()
Dim rng As Range
Dim cel As Range
Dim wks As Worksheet
Dim wksNew As Worksheet
Dim bFlag As Boolean
Set rng = Worksheets("Master").Range("A1:A11") 'change this to suit your range of names
For Each cel In rng

bFlag = False

For Each wks In ThisWorkbook.Worksheets

If wks.Name = cel Then
bFlag = True: Exit For
End If

Next wks

If Not bFlag Then
Set wksNew = ThisWorkbook.Worksheets.Add
wksNew.Name = cel
Set wksNew = Nothing
End If


Next cel
End Sub

 

[nuked]

Sub CreateSheets()
Dim rng As Range
Dim cel As Range
Dim wks As Worksheet
Dim wksNew As Worksheet
Dim bFlag As Boolean
Dim iRow As Integer
Set rng = Worksheets("Master").Range("A2:A11")
For Each cel In rng

bFlag = False

For Each wks In ThisWorkbook.Worksheets

If wks.Name = cel Then

iRow = wks.Range("A" & wks.Rows.Count).End(xlUp).Row + 1
wks.Range("A" & iRow) = cel
wks.Range("B" & iRow) = cel.Offset(, 1)

bFlag = True: Exit For
End If

Next wks

If Not bFlag Then
Set wksNew = ThisWorkbook.Worksheets.Add
wksNew.Name = cel
wksNew.[A1] = "Name"
wksNew.[B1] = "Location"
iRow = wksNew.Range("A" & wksNew.Rows.Count).End(xlUp).Row
wksNew.Range("A" & iRow + 1) = cel
wksNew.Range("B" & iRow + 1) = cel.Offset(, 1)
End If

Next cel
End Sub

 

[kevatarvind]

Sub Create_Sheet()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Sheets("Master").Select
Sheets.Add.Name = "Working"
Sheets("Master").Range("A:A").Copy Sheets("Working").Range("A1")
Sheets("Working").Select
ActiveSheet.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlYes
Range("A1").EntireRow.Delete
Sheets("Working").Select
Range("A1").Select
Set my = Sheets("Working").Range("A1")
Do Until ActiveCell.Value = ""
Sheets("Master").Select
Sheets.Add.Name = my
Sheets("Master").UsedRange.Copy
ActiveSheet.Paste
Range("A2").Select
Do Until ActiveCell.Value = ""
If ActiveCell.Value <> my.Value Then
ActiveCell.EntireRow.Delete
Else
ActiveCell.Offset(1, 0).Select
End If
Loop
Range("A1").Select
Sheets("Working").Select
ActiveCell.Offset(1, 0).Select
Set my = my.Offset(1, 0)
Loop
Sheets("Working").Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub