How To Export Your Data Into Separate Workbooks Based On The Values In A Column

2017-05-07

VBA

Something that comes up time and time again in any kind of work is separating data out into separate workbooks based on the values of a field in the data.

Let’s say you have sales data for your company and you need to send each of the sales representatives in the company a copy of their sales. You might not want to share the entire set of data with each rep but just their own sales due to privacy concerns around their commission based compensation. To do this, we will need to take our original set of data and parse it out into many different workbooks (one for each sales rep) based on the sales rep column in the data.

Parsing and exporting data into different workbooks is a very common problem, but unfortunately Excel does not have a built in solution. We would need to manually filter for each item in a column and then copy and paste the filtered data into a new file and save that. This can be very time consuming if we have a lot of values to filter or if this is an activity we will be doing monthly, weekly or even daily. Fortunately, we can automate this with VBA!

This template will allow you to separate out your data by selecting a column to separate it based on. This workbook uses a table called Data to hold the aggregate data. You can adjust the size and column heading to suit your data. Delete or add columns as desired and rename the column headings to suit your own data. The drop down menu will automatically account for the new column headings. Set your save path accordingly, this is where the VBA will save all the new data files it creates. When the template is all set up, press the Run button and your new data files will appear in the save path folder.

The VBA uses named range references so the template is flexible and you can cut and paste the sheet until you’re satisfied and you will not break the code. Here is the VBA code used in the template.

Option Explicit

Sub ExportData()

'Declare variables
Dim ArrayItem As Long
Dim ws As Worksheet
Dim ArrayOfUniqueValues As Variant
Dim SavePath As String
Dim ColumnHeadingInt As Long
Dim ColumnHeadingStr As String
Dim rng As Range

'Set the worksheet to
Set ws = Sheets("Data")

'Set the save path for the files created
SavePath = Range("FolderPath")

'Set variables for the column we want to separate data based on
ColumnHeadingInt = WorksheetFunction.Match(Range("ExportCriteria").Value, Range("Data[#Headers]"), 0)
ColumnHeadingStr = "Data[[#All],[" & Range("ExportCriteria").Value & "]]"

'Turn off screen updating to save runtime
Application.ScreenUpdating = False

'Create a temporary list of unique values from the column we want to
'separate our data based on
Range(ColumnHeadingStr & "").AdvancedFilter Action:=xlFilterCopy, _
    CopyToRange:=Range("UniqueValues"), Unique:=True

'Sort our temporary list of unique values
ws.Range("UniqueValues").EntireColumn.Sort Key1:=ws.Range("UniqueValues").Offset(1, 0), _
    Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
    Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

'Add unique field values into an array
'ArrayOfUniqueValues = Application.WorksheetFunction.Transpose(ws.Range("IV2:IV" & Rows.Count).SpecialCells(xlCellTypeConstants))
ArrayOfUniqueValues = Application.WorksheetFunction.Transpose(ws.Range("UniqueValues").EntireColumn.SpecialCells(xlCellTypeConstants))

'Delete the temporary values
ws.Range("UniqueValues").EntireColumn.Clear

'Loop through our array of unique field values, copy paste into new workbooks and save
For ArrayItem = 1 To UBound(ArrayOfUniqueValues)
    ws.ListObjects("Data").Range.AutoFilter Field:=ColumnHeadingInt, Criteria1:=ArrayOfUniqueValues(ArrayItem)
    ws.Range("Data[#All]").SpecialCells(xlCellTypeVisible).Copy
    Workbooks.Add
    Range("A1").PasteSpecial xlPasteAll
    ActiveWorkbook.SaveAs SavePath & ArrayOfUniqueValues(ArrayItem) & Format(Now(), " YYYY-MM-DD hhmmss") & ".xlsx", 51
    ActiveWorkbook.Close False
    ws.ListObjects("Data").Range.AutoFilter Field:=ColumnHeadingInt
Next ArrayItem

ws.AutoFilterMode = False
MsgBox "Finished exporting!"
Application.ScreenUpdating = True
    
End Sub

Note: This was tested on Excel 2016 but I have not tested it on previous versions.

About the Author

John MacDougall

John MacDougall

John is a Microsoft MVP and freelance consultant and trainer specializing in Excel, Power BI, Power Automate, Power Apps and SharePoint. You can find other interesting articles from John on his blog or YouTube channel.

Subscribe

Advertisement

Related Articles

Comments

16 Comments

  1. Prabhas

    The tool is really nice. one thing i would like to suggest that the out put can be set with ” Autofit Column Width”.

    • John

      Good suggestion. I’ll try to add that in the next few days.

      • Shabbir

        What if file name already exists that it’s going to create? Will this help in uniqueness:
        ActiveWorkbook.SaveAs SavePath & ArrayOfUniqueValues(ArrayItem) & Format(Now(), ” YYYY-MM-DD hhmmss”) & “.xlsx”, 51
        (I’m new to VBA)

        • John

          Yes, a time stamp on the file name is an excellent idea and will prevent duplicates. My solution will currently overwrite any file that already exists.

      • Lou-Ellen

        Hi John – what an awesome tool! Thanks so much for sharing. Do you have the VBA script of how to make the output set to Autofit Column Width? Thanks mate!

  2. Raghu Prabhu

    April 1, 2018 at 12:38 am
    Hi All,

    I have a master file with the following headings

    S No
    Item
    Price
    Qty
    Total
    Distributed
    Task1
    Task2
    Task3
    Task4
    Completed
    Consolidated
    Comments
    Team Member

    The Team leader inputs the data in first 3 columns and selects the name of the team member to be given the task for column 14.

    He then runs the macro ExportByName and new workbooks are created if they already exist then add to the end of the file.

    The team members do the tasks and fill in columns Task1, Task2, Task3, Task4 and then date completed.

    When the team leader runs the following macros

    Sub BringInAllCompletedData()
    Call SortAllFiles
    Call LoopThroughDirectory
    Call UpdateDateInSheet1ColK
    Call UpdateOriginalData
    Call ClearSheet1
    End Sub

    All the work completed is consolidated.

    [code]

    Sub ExportByName()
    Dim unique(1000) As String
    Dim wb(1000) As Workbook
    Dim ws As Worksheet
    Dim x As Long
    Dim y As Long
    Dim ct As Long
    Dim uCol As Long

    On Error GoTo ErrHandler

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False

    ‘Your main worksheet info.
    Set ws = ActiveWorkbook.Sheets(“OriginalData”)

    Let uCol = 14 ‘Column O

    Dim Strt As Long, Stp As Long: Let Strt = ws.Cells(ws.Rows.Count, 6).End(xlUp).Row + 1: Stp = ws.Cells(ws.Rows.Count, uCol).End

    (xlUp).Row

    Let ws.Range(“F” & Strt & “:F” & Stp & “”).Value = Format(Date, “dd/mmm/yyyy”) ‘ adding the dates to the new rows

    Let ws.Range(“A” & Strt & “:A” & Stp & “”).Value = Application.Evaluate(“=row(” & Strt & “:” & Stp & “)-1”) ‘ adding the S.no. to

    the new rows

    ct = 0

    For x = 2 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row
    If CountIfArray(ActiveSheet.Cells(x, uCol), unique()) = 0 Then
    unique(ct) = ActiveSheet.Cells(x, uCol).Text
    ct = ct + 1
    End If
    Next x

    For x = 0 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row – 1
    If unique(x) “” Then
    If Dir(ThisWorkbook.Path & “\” & unique(x) & “.xlsx”, vbNormal) = “” Then ‘If unique file does not exist

    Workbooks.Add: Set wb(x) = ActiveWorkbook
    ws.Range(ws.Cells(1, 1), ws.Cells(1, uCol)).Copy wb(x).Sheets(1).Cells(1, 1)
    Else
    Workbooks.Open filename:=ThisWorkbook.Path & “\” & unique(x) & “.xlsx”
    Set wb(x) = ActiveWorkbook
    End If

    For y = Strt To Stp
    If ws.Cells(y, uCol) = unique(x) Then
    ws.Range(ws.Cells(y, 1), ws.Cells(y, uCol)).Copy
    wb(x).Sheets(1).Cells(WorksheetFunction.CountA(wb(x).Sheets(1).Columns(uCol)) + 1, 1).PasteSpecial

    Paste:=xlPasteValuesAndNumberFormats
    End If
    Next y
    ‘autofit
    wb(x).Sheets(1).Columns.AutoFit
    wb(x).SaveAs ThisWorkbook.Path & “\” & unique(x) & “.xlsx”, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    wb(x).Close SaveChanges:=True
    Else
    ‘Quit loop
    Exit For
    End If
    Next x

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    ErrHandler:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    End Sub

    Public Function CountIfArray(lookup_value As String, lookup_array As Variant)
    CountIfArray = Application.Count(Application.Match(lookup_value, lookup_array, 0))
    End Function

    Sub BringInAllCompletedData()
    Call SortAllFiles
    Call LoopThroughDirectory
    Call UpdateDateInSheet1ColK
    Call UpdateOriginalData
    Call ClearSheet1
    End Sub

    ‘https://www.mrexcel.com/forum/excel-questions/471802-vba-open-file-run-code-close-save-open-next-file.html
    Sub SortAllFiles()
    Dim folderPath As String
    Dim filename As String
    Dim wb As Workbook

    Application.DisplayAlerts = False

    folderPath = ActiveWorkbook.Path & “\” ‘change to suit
    If Right(folderPath, 1) “\” Then folderPath = folderPath + “\”
    filename = Dir(folderPath & “*.xlsx”)
    Do While filename “”
    Application.ScreenUpdating = False
    Set wb = Workbooks.Open(folderPath & filename)
    ‘Call a subroutine here to operate on the just-opened workbook
    If filename = “zmaster.xlsm” Then
    Exit Sub
    Else
    Call SortSheet1InAllFiles
    End If
    filename = Dir
    Loop
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    End Sub

    Sub SortSheet1InAllFiles()
    Dim MyFile As String
    Dim eRow As Long
    Dim RowsConsolidated As Long
    Dim LastRow As Long
    Dim i As Long

    eRow = Sheets(“Sheet1”).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

    Cells.Select
    ActiveWorkbook.Worksheets(“Sheet1”).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(“Sheet1”).Sort.SortFields.Add Key:=Range(“K2:K” & eRow) _
    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(“Sheet1”).Sort
    .SetRange Range(“A1:N” & eRow)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
    End With
    ActiveWorkbook.Save
    Range(“A1”).Select
    ActiveWorkbook.Close

    End Sub

    ‘http://www.exceltrainingvideos.com/transfer-data-multiple-workbooks-master-workbook-automatically/

    Sub LoopThroughDirectory()
    Dim MyFile As String
    Dim eRow As Long
    Dim LRL As Long
    Dim LRK As Long
    Dim i As Long

    Dim FilePath As String
    FilePath = ActiveWorkbook.Path & “\”

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Sheets(“Sheet1”).Activate
    MyFile = Dir(FilePath)
    Do While Len(MyFile) > 0
    If MyFile = “zmaster.xlsm” Then
    Exit Sub
    End If

    Workbooks.Open (FilePath & MyFile)
    LRK = Cells(Rows.Count, 11).End(xlUp).Offset(1, 0).Row ‘Column L
    LRL = Cells(Rows.Count, 12).End(xlUp).Offset(1, 0).Row ‘Column K

    For i = LRL To LRK
    Range(“A” & LRL & ” : ” & “K” & LRK).Copy
    Next
    ActiveWorkbook.Close

    eRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    ActiveSheet.Paste Destination:=Worksheets(“Sheet1”).Range(Cells(eRow, 1), Cells(eRow, 11))

    If MyFile = “zmaster.xlsm” Then
    Exit Sub
    End If

    Workbooks.Open (FilePath & MyFile)
    For i = LRL To LRK – 1
    If Range(“L” & i).Value = “” Then
    Range(“L” & i).Value = Date
    Columns(“L:L”).NumberFormat = “[$-C09]dd-mmm-yy;@”
    End If
    Next
    Range(“A1”).Select
    ActiveWorkbook.Save
    ActiveWorkbook.Close

    MyFile = Dir
    ActiveWorkbook.Save
    Loop

    Columns(“A:D”).Select
    ActiveWorkbook.Worksheets(“Sheet1”).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(“Sheet1”).Sort.SortFields.Add Key:=Range(“A2:A” & eRow) _
    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(“Sheet1”).Sort
    .SetRange Range(“A1:D” & eRow)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
    End With

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    End Sub

    Sub UpdateDateInSheet1ColK()
    Dim eRow As Long
    Dim i As Long

    Sheets(“Sheet1”).Activate
    eRow = Sheets(“Sheet1”).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    For i = 2 To eRow
    If Range(“K” & i) “” Then
    Range(“L” & i).Value = Format(Date, “dd/mmm/yyyy”)
    End If
    Next
    End Sub

    ‘https://www.youtube.com/watch?v=AzhQ5KiNybk
    Sub UpdateOriginalData()
    Dim i As Integer
    Dim j As Integer
    Dim LastRow1 As Integer
    Dim LastRow2 As Integer
    Dim SNo As Double

    LastRow1 = Sheets(“Sheet1”).Range(“A” & Rows.Count).End(xlUp).Row
    LastRow2 = Sheets(“OriginalData”).Range(“A” & Rows.Count).End(xlUp).Row

    For i = 2 To LastRow1
    SNo = Sheets(“Sheet1”).Cells(i, “A”).Value
    Sheets(“OriginalData”).Activate
    For j = 2 To LastRow2
    If Sheets(“OriginalData”).Cells(j, “A”).Value = SNo Then
    Sheets(“Sheet1”).Activate
    Sheets(“Sheet1”).Range(Cells(i, “G”), Cells(i, “L”)).Copy
    Sheets(“OriginalData”).Activate
    Sheets(“OriginalData”).Range(Cells(j, “G”), Cells(j, “L”)).Select
    ActiveSheet.Paste
    End If
    Next j
    Application.CutCopyMode = False
    Next i
    Sheets(“OriginalData”).Activate
    Cells.Select
    ActiveWorkbook.Save
    Selection.Columns.AutoFit
    Range(“A1”).Select

    End Sub

    Sub ClearSheet1()
    Dim eRow As Long

    Sheets(“Sheet1”).Activate
    eRow = Sheets(“Sheet1”).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

    Range(“A2:O” & eRow).Select
    Selection.ClearContents
    Selection.Columns.AutoFit
    Range(“A1”).Select
    ActiveWorkbook.Save
    End Sub
    [/code]

    This is a complete project and I use it at work.

    I am able to do this thanks mainly to guru Dinesh Kumar Takyar.

    Regards

    Raghu Prabhu

  3. Phillip hardcastle

    Hi John,

    I am a novice to Excel VBA and need a little help from you on your code. I need to do exactly what you are describing. I know enough to understand most of it, but in it you reference the following:

    ColumnHeadingInt = WorksheetFunction.Match(Range(“ExportCriteria”).Value, Range(“wks[#Headers]”), 0)
    ColumnHeadingStr = “Distribution_Template[[#All],[” & Range(“ExportCriteria”).Value & “]]”

    The code is giving me a Method ‘Range’ of object’_Worksheet’ failed run-time error (1004). It’s probably because I don’t understand what “ExportCriteria” and “Data[#Headers]” means in the code. They are not defined. Can you explain them?

    • John

      ExportCriteria is a named range in the spreadsheet template. You can use the name box in Excel to navigate to it and confirm it exists (possibly you accidentally deleted it.

      Data[#Headers] is a table reference. There’s a table named Data and we are referencing the column headings part of the table.

  4. Bianca

    Hi John,

    This is such an amazing template! However, I wanted to know if there was a way to copy and paste as a table instead of values? I haven’t been trying to manipulate the code but haven’t been able to figure it out.

  5. Elaine

    Hi, I can’t download the Example file 😦

    • John

      I just tested it out. Works fine. Click on the orange button then click on the download icon in the upper right.

  6. Andrea

    Hi John, thank you so much for this template! it works great!!
    How would you recommend me to edit the code to instead of selecting all the filtered rows, it would only select the first 25 (additional to the header)?

    • John

      Based on the way this code works, there isn’t a way to modify it to do that. Excel has no option to filter on the first N items.

      If you added a column to your data that was an index for each unique item in that field, you could add a criteria filter on the index >= 25.

      ws.ListObjects("Data").Range.AutoFilter Field:=ColumnHeadingInt, Criteria1:=ArrayOfUniqueValues(ArrayItem)

      You would need to modify the above line of code accordingly with a Criteria2. Best of luck!

  7. Krishna

    The Export criteria column I used should not be present in the files created by Macro. Can you please help me with that?

  8. Jeff C

    This solved my challenge – now if they would only give me a raise, lol. Thanks, John!

  9. William Smith

    Hi John, I left an earlier message about adding code that will copy existing data validation(s) from the source worksheet (“data”) to the new workbook(s). I don’t recall if I also commented on the need to copy two supporting worksheets from the source workbook. I know there are many examples of copying worksheets so the trick will be to include the needed code within your macro. I’m assuming the correction section would be:

    ‘Loop through our array of unique field values, copy paste into new workbooks and save
    For ArrayItem = 1 To UBound(ArrayOfUniqueValues)
    ws.ListObjects(“Data”).Range.AutoFilter Field:=ColumnHeadingInt, Criteria1:=ArrayOfUniqueValues(ArrayItem)
    ws.Range(“Data[#All]”).SpecialCells(xlCellTypeVisible).Copy
    Workbooks.Add
    Range(“A1″).PasteSpecial xlPasteAll
    ActiveWorkbook.SaveAs SavePath & ArrayOfUniqueValues(ArrayItem) & Format(Now(), ” YYYY-MM-DD hhmmss”) & “.xlsx”, 51
    ActiveWorkbook.Close False
    ws.ListObjects(“Data”).Range.AutoFilter Field:=ColumnHeadingInt
    Next ArrayItem

    I would also need to set ws = Sheets(“Data”) to include the additional sheets therefore:

    set ws = Sheets(“Data”,”Lists”,”FX”)

    If i’m reading your code correctly, I don’t think including the additional worksheets will interfere with how your code executes. I just need to add the code to copy the additional worksheets.

Get The Latest News

Follow Us

Follow us on social media to stay up to date with the latest tips in Excel!

Pin It on Pinterest

Share This