using different column data for saving excel workbooks


New Member
Jan 7, 2018
I managed to pull out excel data based on my column filters and but I wanted to save them according to a different column data for the file names.
The example of the table that is used to pull the data is like this:

  |      A        |         B          |         C         | D |       E         |
    |Material number|Material description|Manufacturer number|Qty|Manufacturer Name|
    | 01123334        |   PCB                   |   546789                  | 3  |   Adam corp          |
    | 01123334        |   Resistors            |   546800                  | 6  |   Adrian corp          | 
    | 01123334        |   chips                 |   546789                   | 2  |   Adam corp          |
    | 01123334        |   LED                   |   546800                   | 9  |   Adrian corp          |
At first i tried to directly pull from column E but some of the data in column E exceeded 31 characters and caused some blank excel workbooks to be saved when running the code

So I tried pulling from column B which is their ID but the problem is how do I modify the code for it to save the files extracted using column E's data for the file names

I really hope someone can provide some advice or solution for this problem as I am new to VBA macro programming and I hope to learn more ways to implement this code to my everyday tasks

Below is the codes for pulling out the filtered data and saving the files:

        Sub ExportDatabaseToSeparateFiles()
    'Export is based on the value in the KeyCol
        Dim myCell As Range
        Dim mySht As Worksheet
        Dim myName As String
        Dim myArea As Range
        Dim myShtName As String
        Dim KeyCol As String
        Dim myField As Integer
        myShtName = ActiveSheet.Name
        KeyCol = "C"
        Set myArea = Intersect(ActiveSheet.UsedRange, Range(KeyCol & "1").EntireColumn).Cells
        Set myArea = myArea.Offset(1, 0).Resize(myArea.Rows.Count - 1, 1)
        myField = myArea.Column - myArea.CurrentRegion.Cells(1).Column + 1
        For Each myCell In myArea
            On Error GoTo NoSheet
            myName = Worksheets(myCell.Value).Name
            GoTo SheetExists:
            Set mySht = Worksheets.Add(Before:=Worksheets(1))
            mySht.Name = myCell.Value
            With myCell.CurrentRegion
                .AutoFilter Field:=myField, Criteria1:=myCell.Value
                .SpecialCells(xlCellTypeVisible).Copy _
            End With
        Next myCell
        For Each mySht In ActiveWorkbook.Worksheets
            If mySht.Name = myShtName Then
                Exit Sub
                ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & ActiveSheet.Name & ".xlsx"
            End If
        Next mySht
    End Sub

Some videos you may like

Excel Facts

Return population for a City
If you have a list of cities in A2:A100, use Data, Geography. Then =A2.Population and copy down.


MrExcel MVP, Moderator
Jun 12, 2014
Office Version
  1. 365
  1. Windows
Hi & welcome to the board
One option is to change this line as shown
.AutoFilter Field:=3, Criteria1:=myCell.Value
Another option is this
Sub CopyToNewWorkbook()

   Dim Cl As Range
   Dim Dic As Object
   Dim Ky As Variant
   Dim Wbk As Workbook
Application.ScreenUpdating = False

   Set Dic = CreateObject("scripting.dictionary")
      For Each Cl In Range("C2", Range("C" & Rows.Count).End(xlUp))
         If Not Dic.exists(Cl.Value) Then
            Dic.Add Cl.Value, Union(Range("C1"), Cl)
            Set Dic.Item(Cl.Value) = Union(Dic.Item(Cl.Value), Cl)
         End If
      Next Cl
      For Each Ky In Dic.Keys
         Set Wbk = Workbooks.Add(1)
         Wbk.Sheets(1).Name = Ky
         Dic(Ky).EntireRow.Copy Wbk.Sheets(1).Range("A1")
         Wbk.SaveAs ThisWorkbook.path & "\" & Ky, 51
         Wbk.Close False
      Next Ky
End Sub

Watch MrExcel Video

Forum statistics

Latest member

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back