How to split one excel spreadsheet into several files?

Sub test()
Dim myDir As String, a, dic As Object, w(), i As Long, ii As Long, x, y
Dim wsMaster As Worksheet
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = vbTextCompare
With Workbooks.Open("c:\Alice Wong\master.xls").Sheets(1)
     a = .Range("a1").CurrentRegion.Value
End With
For i = 2 To UBound(a,1)
     If Not IsEmpty(a(i,2)) Then
          If Not dic.exists(a(i,2)) Then
               ReDim w(1 To UBound(a,2), 1 To 1)
               For ii = 1 To UBound(a,1) : w(ii,1) = a(i,ii) : Next
               dic.add a(i,2), w
          Else
               w = dic(a(i,2)) : ReDim Preserve w(1 To UBound(a,2), 1 To UBound(w,2) + 1)
               For ii = 1 To UBound(a,2) : w(ii, UBound(w,2)) = a(i,ii) : Next
               dic(a(i,2)) = w
          End If
     End IF
Next
x = dic.Keys : y = dic.items : Set dic = Nothing : Erase a
For i = 0 To UBound(x)
     With Workbooks.Add
          With .Sheets(1)
               .Rows(1).Value = Workbooks("master.xls").Sheets(1).Rows(1).Value
               .Range("a2").Resize(UBound(y(i),2), UBound(y(i),1)).Value = _
                     Application.Transpose(y(i))
          End With
          .SaveAs "c:\Alice Wong\Split Files\" & x(i) & ".xls"
          .Close False
     End With
Next
End Sub

Public Sub CreateUserFiles()

    Dim DataSheet As Worksheet
    Dim UserBook As Workbook
    Dim UserSheet As Worksheet
    Dim Names As New Collection
    Dim NameLoop As Long
    Dim UniqueName As Boolean
    Dim RowLoop As Long
    Dim Folder As String
    
    Application.DisplayAlerts = False
    
    Set DataSheet = ActiveSheet
    Folder = "C:\Alice Wong\Split Files\"
    
    For RowLoop = 1 To DataSheet.Range("B65536").End(xlUp).Row
    
        UniqueName = True
        
        For NameLoop = 1 To Names.Count
            
            If DataSheet.Range("B" & RowLoop) = Names(NameLoop) Then
            
                UniqueName = False
                Exit For
            
            End If
        
        Next NameLoop
        
        If UniqueName Then
        
            Names.Add DataSheet.Range("B" & RowLoop)
        
        End If
    
    Next RowLoop
    
    For NameLoop = 1 To Names.Count
    
        Set UserBook = Workbooks.Add
        Set UserSheet = UserBook.Worksheets.Add
        
        UserSheet.Name = "Details"
        UserBook.Worksheets(Array("Sheet1", "Sheet2", "Sheet3")).Delete
        
        For RowLoop = 1 To DataSheet.Range("B65536").End(xlUp).Row
        
            If DataSheet.Range("B" & RowLoop) = Names(NameLoop) Then
            
                DataSheet.Range("C" & RowLoop & ":IV" & RowLoop).Copy
                
                If IsEmpty(UserSheet.Range("A1")) Then
                
                    UserSheet.Range("A1").PasteSpecial
                    
                Else
                
                    UserSheet.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial
                
                End If
            
            End If
        
        Next RowLoop
        
        UserBook.SaveAs Folder & Names(NameLoop) & ".xls"
        UserBook.Close False
                    
    Next NameLoop
    
    Application.DisplayAlerts = True
    MsgBox "Completed Processing", vbInformation, "Finished"

End Sub