Create Multiple Sheets from a List

In this article I will show you how to create multiple sheets from a single sheet.  It is about deconstructing one sheet to create new sheets with data that is related to that particular sheet.  If I had a list of names and I want to create a new sheet for each name and have all of that data that relates to that name on the sheet, then this procedure will create that.

The coding is quite simple, I will use some of the lessons from prior posts to generate a unique list.  The data in this example will be based on column M.  The code will use an advanced filter to look through column M and isolate all of the unique entries.  It will apply these entries to an array then loop through the array to make a new sheet for each unique entry.  I use the Evaluate technique to determine if the sheet exists.  If it does not exist a new sheet will be created with a unique name.

The following is the procedure to create a new sheet with the data that relates to that sheet from a master worksheet.  

Option Explicit

Sub NewSheets() 'Create new sheets based on a list with Excel VBA.
Dim lr As Long
Dim ws As Worksheet
Dim i As Integer
Dim ar As Variant
Dim j As Long
Dim rng As Range

Set ws=Sheet1 'Sheets code name
lr=ws.Range("M" & Rows.Count).End(xlUp).Row
Set rng=ws.Range("M1:M" & lr)
j=[A1].CurrentRegion.Columns.Count + 1

rng.AdvancedFilter 2, , Cells(1, j), True
ar=ws.Range(ws.Cells(2, j), ws.Cells(Rows.Count, j).End(xlUp))
Columns(j).Clear

For i=1 To UBound(ar)
rng.AutoFilter 1, ar(i, 1)
If Not Evaluate("=ISREF('" & ar(i, 1) & "'!A1)") Then 'Check if sheet exists.
Sheets.Add(after:=Sheets(Sheets.Count)).Name=ar(i, 1)
Else
Sheets(ar(i, 1)).Move after:=Sheets(Sheets.Count)
End If
ws.Range("A1:A" & lr).Resize(, j - 1).Copy [A1]
Next
ws.AutoFilterMode=False
End Sub

The attached file outlines the VBA procedure.