Excel 2013 - Making separate files automatically based on Rep #

Since I don't know VB, is there a way to take the code below and instead of making the user intervene and input a Rep # each time, can the coding be set up so that it will create a separate file for each rep (based on the Rep #), no matter if there are 50 reps, 100 reps, or 500 reps. And each separate rep file should be named according to Rep # and Rep Name - columns A & B and saved in the same folder.

A file is attached.

Sub Separate()

 Dim myValue As String
    Set myWorkbook = ActiveWorkbook
    myValue = InputBox("Make sure you have saved this workbook first!" & Chr(13) & Chr(13) & "Which rep number do you want?")
    If myValue <> "" Then
        introw = 2
        Do Until Cells(introw, 1) = ""
            Select Case Cells(introw, 1)
            Case myValue
                introw = introw + 1
            Case Else
            End Select
        If Cells(2, 2) = "" Then
            MsgBox "No data!"
            Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs Filename:="G:\esu1234\excel\" & Cells(2, 1) & " - " & Cells(2, 2) & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
            Application.DisplayAlerts = True
        End If
            Workbooks.Open Filename:="G:\esu1234\excel\Kevin Sample Data - macro enabled.xlsm"
        ' Abort
    End If

End Sub
Who is Participating?

[Webinar] Streamline your web hosting managementRegister Today

gowflowConnect With a Mentor Commented:
Noted and pls be advised that this macro will do more than your request and here is its functioning:

1) it will go thru the data and at each sales rep it will first look in the said directory if the file already exist.

    a) If no, then it will create a new file and add the corresponding data to it.
    b) If Yes, the file exist then it will append to it a new sheet labeled month year and the time it had run and append the data to it.

2) Once it is done it will give you a feedback on how many Created and how many Updated.

Reason for this is that some salesman like to receive their results broken down by period for the whole year. Anytime you only need to send the latest figures make sure the macro does not have any sales files in the said location.

This version is the latest as there was a small bug in the previous in case file already exist. Pls use this one.
Try running it once ,,, check the data and then run it again keeping the files in the folder where they were created.

Now it does it putting the sales Rep# " - " Rep Name in the file name will that be ok or only the Rep# ?
here you go.

see the attached file too.

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
        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
        .AutoFilterMode = False
    End With
    Application.ScreenUpdating = True
End Sub

Open in new window

[Webinar] Kill tickets & tabs using PowerShell

Are you tired of cycling through the same browser tabs everyday to close the same repetitive tickets? In this webinar JumpCloud will show how you can leverage RESTful APIs to build your own PowerShell modules to kill tickets & tabs using the PowerShell command Invoke-RestMethod.

esu4236Author Commented:
ProfessorJimJam:  It seems to work well, except can you make it so that it is naming each individual file by the Rep # and Rep Name?  So the first rep listed, his file would be 1329 - Lyle. Then I think we're good.
Sorry I made a different Sub as do not agree with the proposed type of coding.

Anyway the Macro is called Separate pls run it and chk results.

here is the code
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
        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
        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
        '---> 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.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
    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

Open in new window

esu4236Author Commented:
gowflow - we're in the testing stage. So far, so good - will keep you posted.
esu4236Author Commented:
gowflow - The macro is working for the end user, and they are very pleased!!! It's saving them a ton of time!!! So thank you so very much for your help on this, and going above and beyond what I even asked for. That's truly great customer service. Your services are very much appreciated. Have a great weekend!!!!
Thank you very much for your very kind words very touched. It is my pleasure to always deliver a true correct working solution.

i am also impressed with your contributions.

you always hit the nail on the head by  providing solutions in the most effective and efficient way.

hats off to you
All Courses

From novice to tech pro — start learning today.