using different column data for saving excel workbooks

wt1155

New Member
Joined
Jan 7, 2018
Messages
3
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:


Code:
  |      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:


Code:
        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:
    NoSheet:
            Set mySht = Worksheets.Add(Before:=Worksheets(1))
            mySht.Name = myCell.Value
            With myCell.CurrentRegion
                .AutoFilter Field:=myField, Criteria1:=myCell.Value
                .SpecialCells(xlCellTypeVisible).Copy _
                        mySht.Range("A1")
                mySht.Cells.EntireColumn.AutoFit
                .AutoFilter
            End With
            Resume
    SheetExists:
        Next myCell
    
        For Each mySht In ActiveWorkbook.Worksheets
            If mySht.Name = myShtName Then
                Exit Sub
            Else
                mySht.Move
                ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & ActiveSheet.Name & ".xlsx"
                ActiveWorkbook.Close
            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.

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
53,384
Office Version
  1. 365
Platform
  1. Windows
Hi & welcome to the board
One option is to change this line as shown
Code:
.AutoFilter Field:=3, Criteria1:=myCell.Value
Another option is this
Code:
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)
         Else
            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

Threads
1,123,535
Messages
5,602,217
Members
414,513
Latest member
junbuggle

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 MrExcel.com.
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 "mrexcel.com".
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
Top