Filter data that changes everyday to a new excel workbook

Hello,

So is have a backlog file with vendors that needs to be filtered one by one vendor, pastate each line with specific vendor data to new excel workbook and save it in folder.

The problem is, i do not know how to clarify filter criteria, as the vendors in excel changes every day.

Should i make it with if criteria including every vendor?

Thank you in advance.

Use Dictionary to extract unique vendor names and then loop through Dictionary elements to apply Autofilter to Filter, Copy to new workbook.

Attach sample workbook if you need code to do so.

I have attached excel to my original post.

This should do it.

Sub Create_Sheets()
    Dim fName As String
    Application.ScreenUpdating = False
    MainFolderPath = "D:\Nadina" & "\"
    sn = Sheet1.Cells(1).CurrentRegion.Value
    Set dic = CreateObject("scripting.dictionary")
    For i = 2 To UBound(sn)
        x0 = dic.Item(sn(i, 2))
    Next
    For j = 0 To dic.Count - 1
        fName = dic.keys()(j)
        fName = RemoveIllegalCharacters(fName)
        With Sheet1
            .Cells(1).CurrentRegion.AutoFilter 2, dic.keys()(j)
            .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy Sheets("Temp").Range("A1")
        End With
        With Sheets("Temp")
            With .Cells(1).CurrentRegion
                .EntireColumn.AutoFit
                .EntireRow.AutoFit
            End With
            .Copy
        End With
        With ActiveWorkbook
            Sheets(1).Name = fName
            .SaveAs MainFolderPath & fName, 51
            .Close
        End With
        Sheets("Temp").Cells(1).CurrentRegion.ClearContents
    Next
    Sheet1.ShowAllData
    Application.ScreenUpdating = True
End Sub

Public Function RemoveIllegalCharacters(ByVal strText As String) As String

    Const cstrIllegals As String = "\,/,:,*,?,"",<,>,|,."
    Dim lngCounter As Long
    Dim astrChars() As String
    astrChars() = Split(cstrIllegals, ",")
    For lngCounter = LBound(astrChars()) To UBound(astrChars())
        strText = Replace(strText, astrChars(lngCounter), "_")
    Next lngCounter
    RemoveIllegalCharacters = strText

End Function

All works fine for me in your example file so did you try that or did you put the code in a different file ?

The files are now also named by vendor numbers. Let me know if you want them by name.

Sub Create_Sheets()
    Dim fName As String
    Application.ScreenUpdating = False
    MainFolderPath = "D:\Nadina" & "\"
    sn = Sheet1.Cells(1).CurrentRegion.Value
    Set dic = CreateObject("scripting.dictionary")
    For i = 2 To UBound(sn)
        x0 = dic.Item(sn(i, 1))
    Next
    For j = 0 To dic.Count - 1
        With Sheet1
            .Cells(1).CurrentRegion.AutoFilter 1, dic.keys()(j)
            .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy Sheets("Temp").Range("A1")
        End With
        With Sheets("Temp")
            With .Cells(1).CurrentRegion
                .EntireColumn.AutoFit
                .EntireRow.AutoFit
            End With
            .Copy
        End With
        With ActiveWorkbook
            Sheets(1).Name = dic.keys()(j)
            .SaveAs MainFolderPath & dic.keys()(j), 51
            .Close
        End With
        Sheets("Temp").Cells(1).CurrentRegion.ClearContents
    Next
    Sheet1.ShowAllData
    Application.ScreenUpdating = True
End Sub