Macro Needed - Create File For Every Change

[CyrusTheVirus]

Hi everyone, been a minute since I've posted, but need some VBA help.

What I need is a macro that will create a file for every change in supervisor and have that file named after the supervisor. I have this data in a table. So basically, what I need is this.

Starting Data:

I need the macro to take the header (always take the header) down to the last row of the first supervisor (Adams, Samuel), and take all the data from the header to Samuel Adam and create a new workbook with that data in it, save it to a folder already created on the desktop titled 'Supervisors', and then name that file 'Adams, Samuel', and save it within that folder. So the file would like look below.

THEN, the macro goes to the next person and does the same thing. So takes the header, then finds the next supervisor (Smith, John), copies that data, saves file into folder etc., so the new file saved in the folder would look like below.

It would then go through the entire worksheet for every change in supervisor and do the same thing. Who can help me?

 

[Trebor76]

Hi there,

Try this:

Option Explicit
Sub Macro1()

    Dim objSupervisors As Object
    Dim varSupervisor As Variant
    Dim lngRow As Long, lngLastRow As Long
    Dim wsSrcTab As Worksheet
    Dim strSavePath As String
    Dim wbNew As Workbook
   
    Application.ScreenUpdating = False
   
    Set objSupervisors = CreateObject("Scripting.Dictionary")
    Set wsSrcTab = ThisWorkbook.Sheets("Sheet1") '<-Sheet name containing data to be split. Change to suit.
    strSavePath = "C:\VBA Examples" '<-Path where the individual files will be saved. Change to suit.
    lngLastRow = wsSrcTab.Range("A:E").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
   
    strSavePath = IIf(Right(strSavePath, 1) <> "\", strSavePath & "\", strSavePath)
   
    For lngRow = 2 To lngLastRow
        If Not objSupervisors.Exists(CStr(wsSrcTab.Range("A" & lngRow))) Then
            objSupervisors.Add CStr(wsSrcTab.Range("A" & lngRow)), lngRow
        End If
    Next lngRow
   
    For Each varSupervisor In objSupervisors
        Set wbNew = Workbooks.Add(1) 'Create a new workbook with only one sheet
        wsSrcTab.Range("$A$1:$E$" & lngLastRow).AutoFilter Field:=1, Criteria1:=CStr(varSupervisor), Operator:=xlFilterValues
        wsSrcTab.Range("$A$1:$E$" & lngLastRow).SpecialCells(xlCellTypeVisible).Copy Destination:=wbNew.Sheets(1).Range("A1")
        wbNew.Sheets(1).Columns.AutoFit
        'Save the newly created workbook with a xlsx extension
        Application.DisplayAlerts = False 'Will overwrite an existing file in the 'strSavePath' directory no questions asked. Comment out if not required.
            wbNew.SaveAs strSavePath & CStr(varSupervisor) & ".xlsx", FileFormat:=51 '51 = xlOpenXMLWorkbook (without macro's in 2007-2016, xlsx)
            wbNew.Close
        Application.DisplayAlerts = True
    Next varSupervisor
   
    Application.ScreenUpdating = True
   
    MsgBox "There has been " & Format(objSupervisors.Count, "#,##0") & " supervisor files created in:" & vbNewLine & strSavePath, vbInformation

End Sub

Regards,

Robert

 

[CyrusTheVirus]

Thanks for the reply. Though, I'm getting a run-time error (below). It looks like it creates the new workbook and pastes the data, then the error pops up, so it doesn't get to the stage of saving the workbook to the folder, closing the new workbook, or going to the next supervisor. Thoughts?

 

[Trebor76]

That's odd as it worked for me

Are you saving to a Windows directory i.e. the path has back slashes and not forward slashes like a SharePoint directory? Try stepping through the code by pressing F8 on from anywhere within the code and see which line is causing the issue.

 

[CyrusTheVirus]

Beautiful, it look like it worked, I just needed to tweak the file path. Thank you!!!!!!!!!

 

[Trebor76]

Beautiful, it look like it worked, I just needed to tweak the file path. Thank you!!!!!!!!!

Thanks for letting us know and you're welcome