using different column data for saving excel workbooks

[wt1155]

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

 

[wt1155]

Sry for the view of the table, the alignment is abit off

 

[wt1155]

And its column C not column B im so sry for the mistake

 

[Fluff]

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)
         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