Create Sheets And Copy data To Each Sheet

Sub CreateSheets()
' hiker95, 07/14/2014, ME791312
Dim w1 As Worksheet
Dim lr As Long, lc As Long
Dim a As Variant, i As Long, c As Long, w As String
Application.ScreenUpdating = False
Set w1 = Sheets("Sheet1")
With w1
  lr = .Cells(.Rows.Count, 1).End(xlUp).Row
  lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
  a = .Range(.Cells(1, 1), .Cells(lr, lc))
End With
For c = 3 To lc - 1
  w = a(1, c)
  If Not Evaluate("ISREF('" & w & "'!A1)") Then Worksheets.Add(After:=Sheets(Sheets.Count)).Name = w
  With Sheets(w)
    .UsedRange.Clear
    .Cells(1, 1).Resize(, 2).Value = Array("Part", "Description")
    .Range(.Cells(2, 1), .Cells(lr, 2)).Value = w1.Range(w1.Cells(2, 1), w1.Cells(lr, 2)).Value
    .Range(.Cells(1, 3), .Cells(lr, 3)).Value = w1.Range(w1.Cells(1, c), w1.Cells(lr, c)).Value
    .Columns.AutoFit
  End With
Next c
w1.Activate
Application.ScreenUpdating = True
End Sub