Saving extract of file using old file path and name as a base for new file name

[KCK01]

Hi, I am pretty new to VBA and need your help.
I found some great code here that does almost all that I need. After trying some things and searching the forum and google I can not figure it out Hopefully the experts here can help!
The original code extracts some data from an original file based on a filtered columns data, places the extract in a new file with the worksheet name being the data element from the filtered column, and saves the new file using the worksheets name as the file name. The new file is currently saved to the same folder as the personal.xlsx file which is where the VBA code resides.

The code needs to be changed to accomplish three things:
1. the column used to filter the data in the original column needs to be changed from column A to the column that has the name "WINNER"
2. save the new file to the same folder as the original file
2. the new file name needs to be the same as the original file name with the new file worksheet name concatenated

code
Sub Extract_All_Data_To_New_Workbook()

'this macro assumes that your first row of data is a header row.
'will copy all filtered rows from one worksheet, to another blank workbook
'each unique filtered value will be copied to it's own workbook

'Variables used by the macro
Dim wbDest As Workbook
Dim rngFilter As Range, rngUniques As Range
Dim cell As Range

' Set the filter range (from A1 to the last used cell in column A)
'(Note: you can change this to meet your requirements)
Set rngFilter = Range("A1", Range("A" & Rows.Count).End(xlUp))

Application.ScreenUpdating = False

With rngFilter

' Filter column A to show only one of each item (uniques) in column A
.AdvancedFilter Action:=xlFilterInPlace, Unique:=True

' Set a variable to the Unique values
Set rngUniques = Range("A2", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)

' Clear the filter
ActiveSheet.ShowAllData

End With

' Filter, Copy, and Paste each unique to its own new workbook
For Each cell In rngUniques

' Create a new workbook for each unique value
Set wbDest = Workbooks.Add(xlWBATWorksheet)

'NOTE - this filter is on column A (field:=1), to change
'to a different column you need to change the field number
rngFilter.AutoFilter Field:=1, Criteria1:=cell.Value

' Copy and paste the filtered data to its new workbook
rngFilter.EntireRow.Copy
With wbDest.Sheets(1).Range("A1")
.PasteSpecial xlPasteColumnWidths 'Paste column widths
.PasteSpecial xlPasteValuesAndNumberFormats 'Paste values
End With
Application.CutCopyMode = True

' Name the destination sheet
wbDest.Sheets(1).Name = cell.Value

'Save the destination workbook and close
wbDest.SaveAs ThisWorkbook.Path & Application.PathSeparator & _
cell.Value & " " & Format(Date, "mmm_dd_yyyy")
' wbDest.Close False 'Close the new workbook

Next cell

rngFilter.Parent.AutoFilterMode = False
Application.ScreenUpdating = True

End Sub
/code

 

[Fluff]

Give this a go

Sub Extract_All_Data_To_New_Workbook()

    Dim DestWbk As Workbook
    Dim DataRng As Range
    Dim Cl As Range
    Dim Pth As String
    Dim UsdRws As Long
    Dim WinCol As Long
    
Application.ScreenUpdating = True

    Pth = ActiveWorkbook.FullName
    Pth = Left(Pth, InStr(Pth, ".") - 1)
    
    UsdRws = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    WinCol = Rows(1).Find("Winner", , xlValues, xlWhole, , , False, , False).column
    Set DataRng = ActiveSheet.UsedRange
    With CreateObject("scripting.dictionary")
        For Each Cl In Range(Cells(2, WinCol), Cells(UsdRws, WinCol))
            If Not .exists(Cl.Value) Then
                .Add Cl.Value, Nothing
                Set DestWbk = Workbooks.Add(xlWBATWorksheet)
                DataRng.AutoFilter WinCol, Cl.Value
                DataRng.SpecialCells(xlVisible).copy DestWbk.Sheets(1).Range("A1")
                DestWbk.Sheets(1).Name = Cl.Value
                DestWbk.SaveAs Pth & "-" & Cl.Value, [COLOR=#ff0000]51[/COLOR]
                DestWbk.Close , False
            End If
        Next Cl
    End With
    DataRng.AutoFilter
    
Application.ScreenUpdating = True

End Sub

This will save the new workbooks as .xlsx format, if you want them as .xlsm change the number in red to 52

 

[KCK01]

Give this a go

Sub Extract_All_Data_To_New_Workbook()

    Dim DestWbk As Workbook
    Dim DataRng As Range
    Dim Cl As Range
    Dim Pth As String
    Dim UsdRws As Long
    Dim WinCol As Long
    
Application.ScreenUpdating = True

    Pth = ActiveWorkbook.FullName
    Pth = Left(Pth, InStr(Pth, ".") - 1)
    
    UsdRws = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    WinCol = Rows(1).Find("Winner", , xlValues, xlWhole, , , False, , False).column
    Set DataRng = ActiveSheet.UsedRange
    With CreateObject("scripting.dictionary")
        For Each Cl In Range(Cells(2, WinCol), Cells(UsdRws, WinCol))
            If Not .exists(Cl.Value) Then
                .Add Cl.Value, Nothing
                Set DestWbk = Workbooks.Add(xlWBATWorksheet)
       >>    DataRng.AutoFilter WinCol, Cl.Value
                DataRng.SpecialCells(xlVisible).copy DestWbk.Sheets(1).Range("A1")
                DestWbk.Sheets(1).Name = Cl.Value
                DestWbk.SaveAs Pth & "-" & Cl.Value, [COLOR=#ff0000]51[/COLOR]
                DestWbk.Close , False
            End If
        Next Cl
    End With
    DataRng.AutoFilter
    
Application.ScreenUpdating = True

End Sub

This will save the new workbooks as .xlsx format, if you want them as .xlsm change the number in red to 52

Hi Fluff,
Thank you so much, you are magic! It runs great until it hits a row where the filtered value hits #NA and then cl.value equals ERROR 2042 in the debugging window and a message comes up in the spreadsheet Run-time error '1004'.
Can this be trapped to ignore and allow the program to close smoothly so the users do not get worried? Or does the user need to ensure the data does not contain a #NA ?
If it can be trapped to ignore hopefully the original worksheet can be returned to it's original unfiltered condition.

 

[Fluff]

Try this

Sub Extract_All_Data_To_New_Workbook()

    Dim DestWbk As Workbook
    Dim DataRng As Range
    Dim Cl As Range
    Dim Pth As String
    Dim UsdRws As Long
    Dim WinCol As Long
    
Application.ScreenUpdating = True

    Pth = ActiveWorkbook.FullName
    Pth = Left(Pth, InStr(Pth, ".") - 1)
    
    UsdRws = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    WinCol = Rows(1).Find("Winner", , xlValues, xlWhole, , , False, , False).column
    Set DataRng = ActiveSheet.UsedRange
    With CreateObject("scripting.dictionary")
        For Each Cl In Range(Cells(2, WinCol), Cells(UsdRws, WinCol))
            If Not .exists(Cl.Value) [COLOR=#0000ff]And Not IsError(Cl.Value)[/COLOR] Then
                .Add Cl.Value, Nothing
                Set DestWbk = Workbooks.Add(xlWBATWorksheet)
                DataRng.AutoFilter WinCol, Cl.Value
                DataRng.SpecialCells(xlVisible).copy DestWbk.Sheets(1).Range("A1")
                DestWbk.Sheets(1).Name = Cl.Value
                DestWbk.SaveAs Pth & "-" & Cl.Value, 51
                DestWbk.Close , False
            End If
        Next Cl
    End With
    DataRng.AutoFilter
    
Application.ScreenUpdating = True

End Sub

This should bypass any formula errors

 

[KCK01]

That worked perfectly. Thank you very much for sharing your expertise with me, and all of us!

 

[Fluff]

Glad to help & thanks for the feedback