How to split one excel spreadsheet into several files?

[Alice_Wong]

Hi,

I need help to split one excel spreadsheet (master file) into about 50 smaller files based on the column A "Account Owner". Lets say I have this "master file" located at C:\Alice Wong. I would like to split it into 50 files with name "account owner 01"... "account owner 50" and locate them at C:\Alice Wong\Split Files.
Is there a way to do it rather than manually split them?

Thank you!

Brgds,
Alice

 

[jindon]

Do you just need to create 50 files in a directory?

What do you really want to do with the newly created files?
Anything to copy from master to each file?

 

[Alice_Wong]

oh ya, from the master file, it contains data for the 50 account owners (consolidated), so I need to split them into 50 files with each account owner's data into respective files (like copy from the master file). This account owner (the names) is in Column A of the master file.

 

[J Windebank]

Hi Alice,

How is the data laid out that needs to be copied in to the new files?Creating the files automatically based on the values in column A is a relatively simple task, just need to know how to access the data that needs to be copied in.

Kind regards,
Jordan

 

[Alice_Wong]

Hi Jordan,

The master file have about 36 columns (Column A to AJ). So based on the Account Owner (sorry, it should be in Column B, not A), I would like to split the master file into 50 files (50 account owners), each file contains data from Column A to AJ, from Row 1 (the header) to the last row of data of the respective account owner.
Also, the sheet name for the small file would be "Detail".

Thanks!
Alice

 

[J Windebank]

OK Alice, got it. Give me 5 minutes and I'll come back with a sollution for you.

Regards,
Jordan

 

[jindon]

hope this works

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

 

[J Windebank]

Hi Alice,

Looks like jindon beat me to it, but now I have completed it, I may as well offer you an alternative.

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

Kind regards,
Jordan