Excel 2013 - Making separate files automatically based on Rep #

Sub separateFILES()

    '11/12/2014  by ProfessorJimJam  Solution to question number Q8556076
    Dim colLetter As String, SavePath As String
    Dim lastValue As String
    Dim wb As Workbook
    Dim lng As Long
    Dim currentRow As Long
     colLetter = "A"
    SavePath = "G:\efu1234\Excel\" 'Indicate the path to save
    If SavePath = "" Then SavePath = ActiveWorkbook.Path
    'Sort the workbook.
    Application.ScreenUpdating = False
    With ActiveWorkbook.Worksheets(1)
        .Sort.SortFields.Add Key:=.Range(colLetter & ":" & colLetter), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange .Parent.UsedRange.Cells
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        For lng = 2 To .Range(colLetter & .Rows.Count).End(xlUp).Row
            If .Cells(lng, colLetter).Value = "" Then Exit For
            lastValue = .Cells(lng, colLetter).Value
            .Cells.AutoFilter field:=.Cells(lng, colLetter).Column, Criteria1:=lastValue
            lng = .Cells(.Rows.Count, colLetter).End(xlUp).Row
            Set wb = Application.Workbooks.Add(xlWorksheet)
            wb.Sheets(1).Name = lastValue
            .Rows(1 & ":" & lng).Copy wb.Sheets(1).Cells(Rows.Count, 1).End(xlUp)
            wb.SaveAs SavePath & Replace(lastValue, ".", " "), 51
            wb.Save
            wb.Close
        Next
        .AutoFilterMode = False
    End With
    Application.ScreenUpdating = True
End Sub

Select allOpen in new window

Sub Separate()
Dim WS As Worksheet
Dim WSREP As Worksheet
Dim WBREP As Workbook
Dim MaxRow As Long, I As Long, J As Long, K As Long
Dim sRep As String, sRepFile As String, sFilePath As String, sSheetName As String
Dim SrtRow As Long, EndRow As Long, lCount As Long

'---> Disable Events
With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

Set WS = ActiveSheet
MaxRow = WS.Range("A" & WS.Rows.Count).End(xlUp).Row
sFilePath = "G:\efu1234\excel"
'sFilePath = ActiveWorkbook.Path
sSheetName = WS.Name

For J = 2 To MaxRow - 1
    '---> Get Start and End row for Rep
    SrtRow = J
    K = J
    Do
        K = K + 1
    Loop Until InStr(1, WS.Cells(K, "A"), WS.Cells(J, "A")) = 0
    EndRow = K - 1
    
    '---> Test to see if the rep found already have a workbook
    sRepFile = Dir(sFilePath & "\" & WS.Cells(J, "A") & " - " & WS.Cells(J, "B") & ".xlsx")
    If sRepFile = "" Then
        '---> Create the new Workbook
        WS.Copy
        Set WBREPS = ActiveWorkbook
        sRepFile = sFilePath & "\" & WS.Cells(J, "A") & " - " & WS.Cells(J, "B") & ".xlsx"
        WBREPS.SaveAs Filename:=sRepFile
        Set WSREPS = ActiveSheet
        WSREPS.Name = sSheetName
        lCount = lCount + 1
    Else
        '---> Open the Existing workbook and add the current worksheet
        sRepFile = sFilePath & "\" & WS.Cells(J, "A") & " - " & WS.Cells(J, "B") & ".xlsx"
        Set WBREPS = Workbooks.Open(sRepFile)
        WS.Copy after:=WBREPS.Worksheets(WBREPS.Worksheets.Count)
        Set WSREPS = ActiveSheet
        WSREPS.Name = sSheetName
    End If
    
    
    '---> Remove Unecessary Rows
    WSREPS.Range("A" & EndRow + 1 & ":A" & WSREPS.Rows.Count).EntireRow.Delete
    If SrtRow > 2 Then
        WSREPS.Range("A2:A" & SrtRow - 1).EntireRow.Delete
    End If
    
    '---> Autofit
    WSREPS.UsedRange.EntireColumn.AutoFit
    
    WSREPS.Activate
    WSREPS.Cells(1, "A").Select
    
    '---> Save and close file
    WBREPS.Close savechanges:=True
        
    '---> release variables
    Set WBREPS = Nothing
    Set WSREPS = Nothing
    
    '---> Goto next Rep
    J = EndRow
    
    Application.ScreenUpdating = True
    WS.Activate
    DoEvents
    Application.ScreenUpdating = False
    
Next J


'---> Disable Events
With Application
    .EnableEvents = True
    .ScreenUpdating = True
    .DisplayAlerts = True
End With

MsgBox "A total of " & lCount & " rep files were created successfully.", vbExclamation, "Create Rep Files"


End Sub

Select allOpen in new window