Excel VBA Split data to individual workbooks and save to folders.

 

Another Excel automation shortcut.

This VBA does Cinderella's job, of separating lentils from cinders and sorting them to separate pots!

So excel data like one below, Sorted as per User ( Column A)

and ranges of each user saved to a separate working in the specified folder as per Hyperlink.

Default folder has to be assigned  as a backup, in cases where we did not specify folder for the User.

User4 Data was saved to Default Folder as we did not have folder created at the time of split.

Simple enough VBA, which can be improved by checking if file is open and close it, or make sure VBA saves files with unique name. (If you watch the video, you can notice I got Debug )

File to Download

Code 

Sub Splitter()
Dim DataWS, LnksWS As Worksheet
Dim Hdr, UsrRng, topCell, btmCell, c, copyRng, lCell, dateC, fndLink As Range
Dim usr, usrC, copyR, MyPath, fName, mnth, yr, dflt, msgText As String
Dim r1, r2 As Integer
 msgText = ""
Set LnksWS = Sheets("Links")
If LnksWS Is Nothing Then
        MsgBox "Oops Something went wrong.... Links tab has dissapeared or was renamed."
    Exit Sub
    Else
    
    If Sheets(1).Name = "Links" Then
        Sheets(1).Move after:=Worksheets(2)
    End If
        Sheets(1).Name = "Data to Split"
        dflt = LnksWS.Range("B2").Value
        If dflt = Empty Then
                MsgBox "Please set default folder in Cell B2 first"
                Exit Sub
        End If
        If Dir(dflt, vbDirectory) = "" Then
            MsgBox "Default link does not exist, please check value in cell B2"
             Exit Sub
        End If
End If
Set DataWS = Sheets(1)
DataWS.Activate
Application.ScreenUpdating = False
'sort data first
    With DataWS.Sort
        .SortFields.Clear
        'sort by User Name first
        .SortFields.Add2 Key:=Range("A:A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        'Sort by Date then
        .SortFields.Add2 Key:=Range("D:D"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("A1:" & Cells.SpecialCells(xlCellTypeLastCell).Address)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    Set c = [A2]
    Do Until c.Value = Empty
    usr = c.Value
    r1 = c.Row
    
    Do Until c.Value <> usr
        Set c = c.Offset(1, 0)
    Loop
    Set lCell = c.Offset(-1, 0)
     r2 = lCell.Row
    Set copyRng = Range("1:1, " & r1 & ":" & r2)
     usrC = lCell.Value
    Set fndLink = LnksWS.Range("A:A").Find(usrC)
    MyPath = dflt
    If Not fndLink Is Nothing Then
        MyPath = fndLink.Offset(0, 1)
    End If
    If Dir(MyPath, vbDirectory) = "" Then
        MyPath = dflt
    End If
    If MyPath = dflt Then
    msgText = msgText & usrC & " "
    End If
    
   copyRng.Copy
   Workbooks.Add
   ActiveSheet.Paste
   Application.CutCopyMode = False
   Set dateC = lCell.Offset(0, 3)
   If IsDate(dateC.Value) = True Then
      mnth = "-" & Month(dateC)
      yr = "-" & Year(dateC)
      Else
      mnth = ""
      yr = ""
    End If
    
        
    fName = MyPath & "\" & lCell.Value & yr & mnth & ".xlsx"
    ChDir MyPath
    ActiveWorkbook.SaveAs FileName:=fName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
    If msgText <> "" Then
        msgText = msgText & " saved in default folder " & dflt
    End If
    c.Activate
   Loop
    Application.ScreenUpdating = True
    MsgBox "Output completed, check Default folder  " & msgText
End Sub