Michael,
              Try this. Function routine is courtesy of Bob Phillips from a
previous posting.

Sub CopyToSheets()

Dim lastrow As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Dim Wks

Set ws1 = ThisWorkbook.Worksheets("MAIN")
ws1.Activate
With ws1
   lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
   For r = 2 To lastrow
       If Not SheetExists(.Cells(r, 1)) Then
           Set NewWS = Worksheets.Add
           NewWS.Name = .Cells(r, 1)
       End If
       Set wks2 = Worksheets(.Cells(r, 1).Value)
       nr = wks2.Cells(Rows.Count, 1).End(xlUp).Row + 1
       ws1.Cells(r, 1).Offset(0, 1).Resize(1, 2).Copy wks2.Range("a" & nr)
   Next r
End With
End Sub
'-----------------------------------------------------------------
Function SheetExists(Sh As String, _
                    Optional wb As Workbook) As Boolean
'-----------------------------------------------------------------
Dim oWs As Worksheet
   If wb Is Nothing Then Set wb = ActiveWorkbook
   On Error Resume Next
   SheetExists = CBool(Not wb.Worksheets(Sh) Is Nothing)
   On Error GoTo 0
End Function