Solved

Excel 2013 - Making separate files automatically based on Rep #

Posted on 2014-11-12
9
89 Views
Last Modified: 2014-11-14
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
                Rows(introw).Delete
            End Select
        Loop
        If Cells(2, 2) = "" Then
            MsgBox "No data!"
        Else
            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"
        myWorkbook.Close
    Else
        ' Abort
    End If

End Sub
Kevin-Sample-Data---macro-enabled.xlsm
0
Comment
Question by:esu4236
  • 4
  • 3
  • 2
9 Comments
 
LVL 29

Expert Comment

by:gowflow
ID: 40438136
Now it does it putting the sales Rep# " - " Rep Name in the file name will that be ok or only the Rep# ?
gowflow
0
 
LVL 25

Expert Comment

by:ProfessorJimJam
ID: 40438159
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
            .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

Open in new window

Kevin-Sample-Data---macro-enabled.xlsm
0
 

Author Comment

by:esu4236
ID: 40438274
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.
0
 
LVL 29

Expert Comment

by:gowflow
ID: 40438333
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
    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

Open in new window




gowflow
Kevin-Sample-Data---macro-enabled.xlsm
0
What Security Threats Are You Missing?

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

 

Author Comment

by:esu4236
ID: 40438680
gowflow - we're in the testing stage. So far, so good - will keep you posted.
0
 
LVL 29

Accepted Solution

by:
gowflow earned 500 total points
ID: 40439295
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.

gowflow
Kevin-Sample-Data-V01.xlsm
0
 

Author Closing Comment

by:esu4236
ID: 40442695
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!!!!
0
 
LVL 29

Expert Comment

by:gowflow
ID: 40442875
Thank you very much for your very kind words very touched. It is my pleasure to always deliver a true correct working solution.
Regards
gowflow
0
 
LVL 25

Expert Comment

by:ProfessorJimJam
ID: 40443116
gowflow,

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
0

Featured Post

Find Ransomware Secrets With All-Source Analysis

Ransomware has become a major concern for organizations; its prevalence has grown due to past successes achieved by threat actors. While each ransomware variant is different, we’ve seen some common tactics and trends used among the authors of the malware.

Join & Write a Comment

INDEX and MATCH can be used to great effect to replace HLOOKUP and VLOOKUP as it does not have the limitation of needing the data to be sorted so that the reference value is in the first column or row. It also has the ability to perform a bi-directi…
Workbook link problems after copying tabs to a new workbook? David Miller (dlmille) Intro Have you either copied sheets to a new workbook, and after having saved and opened that workbook, you find that there are links back to the original sou…
The viewer will learn how to use the =DISCRINV command to create a discrete random variable, use this command to model a set of probabilities and outcomes in a Monte Carlo simulation, and learn how to find the standard deviation of a set of probabil…
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.

762 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

20 Experts available now in Live!

Get 1:1 Help Now