Saving of data into separate file using different choice and into different folder

[ec4excel]

Dear All Experts here,

I am thinking of automating the inventory reporting process and has the following needs:

Inventory report consists of 1xx,xxx lines and I do not require to save all customers into separate files. Can I use a worksheet (I named it Request) to input the things that I wanted to save into?

In the worksheet "Request", instead of using a different macro for each different Column, can I just use 1 marco and do all the job as per my sample?

What we are doing now is, we will first sort this whole list of data and make it into a table and select only 1 of them out, copy the chuck of data into a new workbook and save it. Then filter another account and repeat the same process.

Thanks a lot.

[LeoTaxi]

With extra sheet (Help)
and for column C in sheet request only 1 letter

Sub test()
Dim lr As Long, arr As Variant, x As Long
Application.ScreenUpdating = False
With Sheets("Request")
    arr = .Range("A1", "C" & .Range("A" & .Rows.Count).End(xlUp).Row)
    For x = 1 To UBound(arr)
        If arr(x, 3) = "" Then arr(x, 3) = arr(x - 1, 3)
    Next
End With
Sheets("P").Range("A1").CurrentRegion.ClearContents
Sheets("C").Range("A1").CurrentRegion.ClearContents
Sheets("T").Range("A1").CurrentRegion.ClearContents
With Sheets("Sheet1")
    colp = Application.Match("Product", .Range("1:1"), 0)
    colc = Application.Match("Customer Code", .Range("1:1"), 0)
    colt = Application.Match("Type", .Range("1:1"), 0)
    If .AutoFilterMode Then .AutoFilter.ShowAllData
    For x = 1 To UBound(arr)
        Select Case arr(x, 3)
            Case Is = "C"
                .Range("A1").CurrentRegion.AutoFilter field:=colc, Criteria1:=arr(x, 1)
                With .Range("A1").CurrentRegion
                    .Offset(1).Copy Sheets("Help").Range("A1")
                End With
                With Sheets("Help")
                    lr = .Range("A" & .Rows.Count).End(xlUp).Row
                    .Sort.SortFields.Add2 Key:=Range(Cells(1, colp), Cells(lr, colp)) _
                    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                End With
                With Sheets("Help").Sort
                    .SetRange Range("A1").CurrentRegion
                    .Header = xlNo
                    .MatchCase = False
                    .Orientation = xlTopToBottom
                    .SortMethod = xlPinYin
                    .Apply
                End With
                Sheets("Help").Copy
                ActiveWorkbook.SaveAs arr(x, 2) & "\" & Range("B1").Value & ".xlsx"
                ActiveWorkbook.Close True
                Sheets("Help").Range("A1").CurrentRegion.ClearContents
            Case Is = "P"
                .Range("A1").CurrentRegion.AutoFilter field:=colp, Criteria1:=arr(x, 1)
                With .Range("A1").CurrentRegion
                    .Offset(1).Copy Sheets("Help").Range("A1")
                End With
                With Sheets("Help")
                    lr = .Range("A" & .Rows.Count).End(xlUp).Row
                    .Sort.SortFields.Add2 Key:=Range(Cells(1, colc), Cells(lr, colc)) _
                    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                End With
                With Sheets("Help").Sort
                    .SetRange Range("A1").CurrentRegion
                    .Header = xlNo
                    .MatchCase = False
                    .Orientation = xlTopToBottom
                    .SortMethod = xlPinYin
                    .Apply
                End With
                Sheets("Help").Copy
                ActiveWorkbook.SaveAs arr(x, 2) & "\" & Range("A1").Value & ".xlsx"
                ActiveWorkbook.Close True
                Sheets("Help").Range("A1").CurrentRegion.ClearContents
            Case Is = "T"
                .Range("A1").CurrentRegion.AutoFilter field:=colt, Criteria1:=arr(x, 1)
                With .Range("A1").CurrentRegion
                    .Offset(1).Copy Sheets("Help").Range("A1")
                End With
                With Sheets("Help")
                    lr = .Range("A" & .Rows.Count).End(xlUp).Row
                    .Sort.SortFields.Add2 Key:=Range(Cells(1, colc), Cells(lr, colc)) _
                    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                    .Sort.SortFields.Add2 Key:=Range(Cells(1, colp), Cells(lr, colp)) _
                    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                End With
                With Sheets("Help").Sort
                    .SetRange Range("A1").CurrentRegion
                    .Header = xlNo
                    .MatchCase = False
                    .Orientation = xlTopToBottom
                    .SortMethod = xlPinYin
                    .Apply
                End With
                Sheets("Help").Copy
                ActiveWorkbook.SaveAs arr(x, 2) & "\" & Range("C1").Value & ".xlsx"
                ActiveWorkbook.Close True
                Sheets("Help").Range("A1").CurrentRegion.ClearContents
        End Select
        .AutoFilter.ShowAllData
    Next
End With
End Sub

Kind regards
Leo

[ec4excel]

Dear LeoTaxi,

Thank you for your respond. After I download the file, it gives error when I open the file. The error messages are:
Removed Records: Sorting from /xl/worksheets/sheet1.xml.part
Removed Records: Sorting from /xl/worksheets/sheet4.xml.part
Removed Records: Sorting from /xl/worksheets/sheet5.xml.part
Removed Records: Sorting from /xl/worksheets/sheet6.xml.part


If I used the sample file to run the code, the file name was not correct for both data "Customer Code" and "Product". Only the file name for Type is correct.

Next, I had tried out to copy and paste my actual data into the sample file. My actual data in Sheet1 has up till column K and the rows is about 160,000.

It gives an error and the error is on Ln21, Col 34 as I just tried on Request page using only 1 line to call out 1 code. (The code is still on Column A of Sheet1).

Please help.

[dangelor]

Possibly...

Sub Filter_and_Save()
    Dim v As Variant, i As Long
    Dim rg As Range, c As Range, wb As Workbook

    v = Worksheets("Request").Cells(1, 1).CurrentRegion.Value
    Set rg = Worksheets("Sheet1").Cells(1, 1).CurrentRegion
    For i = 1 To UBound(v)
        If Not rg.Parent.AutoFilter Is Nothing Then rg.Parent.ShowAllData
        Set c = rg.Find(v(i, 1))
        If Not c Is Nothing Then
            Set wb = Workbooks.Add
            rg.AutoFilter c.Column, c.Value
            rg.SpecialCells(xlCellTypeVisible).Copy wb.Worksheets(1).Cells(1, 1)
            wb.SaveAs v(i, 2) & Application.PathSeparator & c.Value, 51
        End If
    Next i
End Sub

[ec4excel]

Possibly...

Sub Filter_and_Save()
    Dim v As Variant, i As Long
    Dim rg As Range, c As Range, wb As Workbook

    v = Worksheets("Request").Cells(1, 1).CurrentRegion.Value
    Set rg = Worksheets("Sheet1").Cells(1, 1).CurrentRegion
    For i = 1 To UBound(v)
        If Not rg.Parent.AutoFilter Is Nothing Then rg.Parent.ShowAllData
        Set c = rg.Find(v(i, 1))
        If Not c Is Nothing Then
            Set wb = Workbooks.Add
            rg.AutoFilter c.Column, c.Value
            rg.SpecialCells(xlCellTypeVisible).Copy wb.Worksheets(1).Cells(1, 1)
            wb.SaveAs v(i, 2) & Application.PathSeparator & c.Value, 51
        End If
    Next i
End Sub

Dear dangelor,

Your code works in the sample workbook but all the new workbook was all "opened".

The code cannot work when I continue the file by deleting away the required information in "Request" worksheet and key in a new query on Column A, line 2 only.

The naming of the file names and folder all tally but it could not work using my actual data.

I had tried your code by copy and pasting my data to the sample workbook and the following occurs:

A new workbook with the wrong information was copied and an error message reads"

"Run-time error '1004':

Microsoft Excel cannot access the file
'C\Users\xxx\Documents\Folder\YYY\57BF4B00'. There are several possible reasons:
Where xxx is my user name and YYY is the error code of the code in the new workbook (as the error code has a "\" separator).

The Request code that I had tested does not have "\" as separator and I keyed in only 1 line to do the test.

[LeoTaxi]

Something wrong with file, dont know what so i create a new one, with small modification in code

Sub test()
Dim lr As Long, arr As Variant, x As Long
Application.ScreenUpdating = False
With Sheets("Request")
    arr = .Range("A1", "C" & .Range("A" & .Rows.Count).End(xlUp).Row)
    For x = 1 To UBound(arr)
        If arr(x, 3) = "" Then arr(x, 3) = arr(x - 1, 3)
    Next
End With
With Sheets("Sheet1")
    colp = Application.Match("Product", .Range("1:1"), 0)
    colc = Application.Match("Customer Code", .Range("1:1"), 0)
    colt = Application.Match("Type", .Range("1:1"), 0)
    If .AutoFilterMode Then .AutoFilter.ShowAllData
    For x = 1 To UBound(arr)
        Select Case arr(x, 3)
            Case Is = "C"
                .Range("A1").CurrentRegion.AutoFilter field:=colc, Criteria1:=arr(x, 1)
                With .Range("A1").CurrentRegion
                    .Offset(1).Copy Sheets("Help").Range("A1")
                End With
                With Sheets("Help")
                    lr = .Range("A" & .Rows.Count).End(xlUp).Row
                    .Sort.SortFields.Add2 Key:=Range(Cells(1, colp), Cells(lr, colp)) _
                    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                End With
                With Sheets("Help").Sort
                    .SetRange Range("A1").CurrentRegion
                    .Header = xlNo
                    .MatchCase = False
                    .Orientation = xlTopToBottom
                    .SortMethod = xlPinYin
                    .Apply
                End With
                Sheets("Help").Copy
                ActiveWorkbook.SaveAs arr(x, 2) & "\" & Range("A1").Value & ".xlsx"
                ActiveWorkbook.Close True
                Sheets("Help").Range("A1").CurrentRegion.ClearContents
            Case Is = "P"
                .Range("A1").CurrentRegion.AutoFilter field:=colp, Criteria1:=arr(x, 1)
                With .Range("A1").CurrentRegion
                    .Offset(1).Copy Sheets("Help").Range("A1")
                End With
                With Sheets("Help")
                    lr = .Range("A" & .Rows.Count).End(xlUp).Row
                    .Sort.SortFields.Add2 Key:=Range(Cells(1, colc), Cells(lr, colc)) _
                    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                End With
                With Sheets("Help").Sort
                    .SetRange Range("A1").CurrentRegion
                    .Header = xlNo
                    .MatchCase = False
                    .Orientation = xlTopToBottom
                    .SortMethod = xlPinYin
                    .Apply
                End With
                Sheets("Help").Copy
                ActiveWorkbook.SaveAs arr(x, 2) & "\" & Range("B1").Value & ".xlsx"
                ActiveWorkbook.Close True
                Sheets("Help").Range("A1").CurrentRegion.ClearContents
            Case Is = "T"
                .Range("A1").CurrentRegion.AutoFilter field:=colt, Criteria1:=arr(x, 1)
                With .Range("A1").CurrentRegion
                    .Offset(1).Copy Sheets("Help").Range("A1")
                End With
                With Sheets("Help")
                    lr = .Range("A" & .Rows.Count).End(xlUp).Row
                    .Sort.SortFields.Add2 Key:=Range(Cells(1, colc), Cells(lr, colc)) _
                    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                    .Sort.SortFields.Add2 Key:=Range(Cells(1, colp), Cells(lr, colp)) _
                    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                End With
                With Sheets("Help").Sort
                    .SetRange Range("A1").CurrentRegion
                    .Header = xlNo
                    .MatchCase = False
                    .Orientation = xlTopToBottom
                    .SortMethod = xlPinYin
                    .Apply
                End With
                Sheets("Help").Copy
                ActiveWorkbook.SaveAs arr(x, 2) & "\" & Range("C1").Value & ".xlsx"
                ActiveWorkbook.Close True
                Sheets("Help").Range("A1").CurrentRegion.ClearContents
        End Select
        .AutoFilter.ShowAllData
    Next
End With
End Sub

[ec4excel]

Something wrong with file, dont know what so i create a new one, with small modification in code

Sub test()
Dim lr As Long, arr As Variant, x As Long
Application.ScreenUpdating = False
With Sheets("Request")
    arr = .Range("A1", "C" & .Range("A" & .Rows.Count).End(xlUp).Row)
    For x = 1 To UBound(arr)
        If arr(x, 3) = "" Then arr(x, 3) = arr(x - 1, 3)
    Next
End With
With Sheets("Sheet1")
    colp = Application.Match("Product", .Range("1:1"), 0)
    colc = Application.Match("Customer Code", .Range("1:1"), 0)
    colt = Application.Match("Type", .Range("1:1"), 0)
    If .AutoFilterMode Then .AutoFilter.ShowAllData
    For x = 1 To UBound(arr)
        Select Case arr(x, 3)
            Case Is = "C"
                .Range("A1").CurrentRegion.AutoFilter field:=colc, Criteria1:=arr(x, 1)
                With .Range("A1").CurrentRegion
                    .Offset(1).Copy Sheets("Help").Range("A1")
                End With
                With Sheets("Help")
                    lr = .Range("A" & .Rows.Count).End(xlUp).Row
                    .Sort.SortFields.Add2 Key:=Range(Cells(1, colp), Cells(lr, colp)) _
                    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                End With
                With Sheets("Help").Sort
                    .SetRange Range("A1").CurrentRegion
                    .Header = xlNo
                    .MatchCase = False
                    .Orientation = xlTopToBottom
                    .SortMethod = xlPinYin
                    .Apply
                End With
                Sheets("Help").Copy
                ActiveWorkbook.SaveAs arr(x, 2) & "\" & Range("A1").Value & ".xlsx"
                ActiveWorkbook.Close True
                Sheets("Help").Range("A1").CurrentRegion.ClearContents
            Case Is = "P"
                .Range("A1").CurrentRegion.AutoFilter field:=colp, Criteria1:=arr(x, 1)
                With .Range("A1").CurrentRegion
                    .Offset(1).Copy Sheets("Help").Range("A1")
                End With
                With Sheets("Help")
                    lr = .Range("A" & .Rows.Count).End(xlUp).Row
                    .Sort.SortFields.Add2 Key:=Range(Cells(1, colc), Cells(lr, colc)) _
                    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                End With
                With Sheets("Help").Sort
                    .SetRange Range("A1").CurrentRegion
                    .Header = xlNo
                    .MatchCase = False
                    .Orientation = xlTopToBottom
                    .SortMethod = xlPinYin
                    .Apply
                End With
                Sheets("Help").Copy
                ActiveWorkbook.SaveAs arr(x, 2) & "\" & Range("B1").Value & ".xlsx"
                ActiveWorkbook.Close True
                Sheets("Help").Range("A1").CurrentRegion.ClearContents
            Case Is = "T"
                .Range("A1").CurrentRegion.AutoFilter field:=colt, Criteria1:=arr(x, 1)
                With .Range("A1").CurrentRegion
                    .Offset(1).Copy Sheets("Help").Range("A1")
                End With
                With Sheets("Help")
                    lr = .Range("A" & .Rows.Count).End(xlUp).Row
                    .Sort.SortFields.Add2 Key:=Range(Cells(1, colc), Cells(lr, colc)) _
                    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                    .Sort.SortFields.Add2 Key:=Range(Cells(1, colp), Cells(lr, colp)) _
                    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                End With
                With Sheets("Help").Sort
                    .SetRange Range("A1").CurrentRegion
                    .Header = xlNo
                    .MatchCase = False
                    .Orientation = xlTopToBottom
                    .SortMethod = xlPinYin
                    .Apply
                End With
                Sheets("Help").Copy
                ActiveWorkbook.SaveAs arr(x, 2) & "\" & Range("C1").Value & ".xlsx"
                ActiveWorkbook.Close True
                Sheets("Help").Range("A1").CurrentRegion.ClearContents
        End Select
        .AutoFilter.ShowAllData
    Next
End With
End Sub

Dear LeoTaxi,

I think I know what causes the error.

My sample file has only 4 columns but my actual data file the columns is until K where some of the columns after F will be blank. But from column A to F will be filled with data.

The next problem will be, in column A, I will have files with "\" as separators, which is not "acceptable" to be named as file name. On top of this naming problem, the other problem will be the decision to "identify" the search.

Meaning, I will have account code like this:

KFC - Level 1
California - Level 2
Alhambra - Level 3

Combine together will be KFC\California\Alhambra.

I can have:
KFC\California\Alhambra
KFC\California\Chico
KFC\FLORIDA\BARTOW
KFC\FLORIDA\CAPECOR

So, when I input into the "request" column A, when I key in KFC, it will gives error.

Is it possible to extract out the following if I enter into request column A:

KFC (to extract all information with Level 1 account code KFC, including all of California and Florida?)

KFC\FLORIDA (to extract all information with Level 1 account code KFC and all Level 2 code Florida?)

KFC\California\Chico (to extract only Chico?)

And lastly, the naming of the file, to replace "\" with "-" or "_"?

If this is not possible, I shall close this post.

[dangelor]

Assumes requests begin in cell A1

Beware - this code will overwrite any existing file with the same name.

Sub Filter_and_Save_v2()
    Dim v As Variant, i As Long, sPath As String
    Dim rg As Range, c As Range, wb As Workbook

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    v = Worksheets("Request").Cells(1, 1).CurrentRegion.Value
    Set rg = Worksheets("Sheet1").Cells(1, 1).CurrentRegion
    For i = 1 To UBound(v)
        If Not rg.Parent.AutoFilter Is Nothing Then rg.Parent.ShowAllData
        Set c = rg.Find(v(i, 1))
        If Not c Is Nothing Then
            Set wb = Workbooks.Add
            rg.AutoFilter c.Column, c.Value
            rg.SpecialCells(xlCellTypeVisible).Copy wb.Worksheets(1).Cells(1, 1)
            If Right(v(i, 2), 1) = "\" Then
                sPath = v(i, 2)
            Else
                sPath = v(i, 2) & "\"
            End If
            wb.SaveAs sPath & c.Value, 51
            wb.Close
        End If
    Next i
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
End Sub

[LeoTaxi]

And lastly, the naming of the file, to replace "\" with "-" or "_"?

this can be done

KFC\California\Chico (to extract only Chico?)

I would say put only Chico in request

Level 1 account code KFC and all Level 2 code

how can i see what is leve1 or level 2, not clear in file

so maybe new exemple file from you, with some answers.

Kind regards
Leo