split data into multiple workbooks with 3 conditions.

[malaionfun]

HI admin,

I require a macro file or coding to split data into multiple workbooks but with 3 conditions.

Ex column A to E have the below data.

A is supplier name
B is supplier's region
C is Currency
D is Product.
E is amount

Here I will have different suppliers who are from different region however there is a chance that supplier name could be same in different region. When the country changes the currency also would change. I would need a separate file for the suppliers who are from different regions even if their names are similar.

Hence I need a macro to create multiple workbook based on the filtering criterias below

Supplier Name
Supplier's Region
Currency

Hope you could help me.

Regards,
Malai

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA

[Excel Fox]

malaionfun,

Welcome to ExcelFox Community.

It would be best to upload a sample workbook that represent the layout and structure of your original workbook, so that developers here can understand the input viz a viz the output.

Regards,
Sam

[malaionfun]

Hi admin,

Please find the attached sample report as requested.

I have given the sample data in the tab one and tab 2 is the output in the format I required.

The split file should be segregated with the below criteria

1. Country
2. Payment/Recovery
3. Currency

For Example, spain have both debit and credit with two different currency namely GBP and EUR.

I require the separate file for each criteria, a file can contain line items of Spain, debit, GBP and new file for Spain,Debit,EUR.

Hope this helps.

Thanks and regards,
Malaionfun

malaionfun,

Welcome to ExcelFox Community.

It would be best to upload a sample workbook that represent the layout and structure of your original workbook, so that developers here can understand the input viz a viz the output.

Regards,
Sam

Sample report.xlsSample report.xls

[Admin]

Hi,

Try this.

Sub kTest()
    
    Dim k, Data As Range, x, Hdr, i As Long, Crits, s As String
    Dim wbkActive   As Workbook, wbkNew As Workbook, j As Long
    Dim FN  As String, Cols
    
    Set wbkActive = ThisWorkbook
    
    Hdr = Array("Gateway", "Supplier Code", "Formulated Column", "Supplier Code", _
                "Reference", "Amount (£)", "Doc Currency", "Country", "Invoice Number")
    Cols = Array(3, 6, , 7, 5, 8, 9, 11, 4)
    
    Application.ScreenUpdating = False
    
    With wbkActive.Sheets("workings")
        If .AutoFilterMode Then .AutoFilterMode = False
        Set Data = .Range("a1:l" & .Range("a" & .Rows.Count).End(xlUp).Row)
        k = Data.Value2
    End With
    With CreateObject("scripting.dictionary")
        .comparemode = 1
        For i = 2 To UBound(k, 1)
            If Len(k(i, 2)) Then
                s = k(i, 2) & "|" & k(i, 9) & "|" & k(i, 11)
                If Not .exists(s) Then
                    .Add s, Nothing
                End If
            End If
        Next
        k = .keys
    End With
    
    With Data
        For i = 0 To UBound(k)
            x = Split(k(i), "|")
            .AutoFilter 2, x(0), 1
            .AutoFilter 9, x(1), 1
            .AutoFilter 11, x(2)
            FN = .Offset(1).Cells(1, .Columns.Count).Value
            Set wbkNew = Workbooks.Add
            With wbkNew.Sheets(1)
                .Range("a2:a4") = Application.Transpose([{"File Number","Payment/Recovery","Currency"}])
                .Range("a7").Resize(, UBound(Hdr) + 1) = Hdr
                .Range("b2") = FN
                .Range("b3") = x(0)
                .Range("b4") = x(1)
            End With
            On Error Resume Next
            For j = 0 To UBound(Cols)
                .Columns(Cols(j)).Copy wbkNew.Sheets(1).Cells(8, j + 1)
            Next
            On Error GoTo 0
            wbkNew.Sheets(1).Rows(8).Delete
            wbkNew.SaveAs wbkActive.Path & "\" & FN & "-" & x(0) & "-" & x(1) & "-" & x(2), 51
            wbkNew.Close
            Set wbkNew = Nothing
        Next
        .Parent.AutoFilterMode = False
    End With
    Application.ScreenUpdating = True
    
End Sub

HTH

[malaionfun]

Hi Admin,

Thank you for your coding.

I already have a excel workbook in which I paste the output of the segregated line items as the sheet 2 has a data for few formulas that I use in sheet 1 along with the output. This coding creates a new file for each output however, Is it possible to put the output data on the template file which I have.

This means I have a file in which there is 2 sheets. I need the output data in sheet 1 and the sheet 2 should remain constant with the data whatever it has. because I need to send the output files to someone who need to work along with sheet2. Each output file should be in this format only.

First sheet of output data which we have segregated and second sheet with default data. I guess we need to create a macro file keeping the sheet1 as template and then need to paste the data to it and then we need to save as it in the required file name.

Is this possible to do?

Regards,
Malai

Hi,

Try this.

Sub kTest()
    
    Dim k, Data As Range, x, Hdr, i As Long, Crits, s As String
    Dim wbkActive   As Workbook, wbkNew As Workbook, j As Long
    Dim FN  As String, Cols
    
    Set wbkActive = ThisWorkbook
    
    Hdr = Array("Gateway", "Supplier Code", "Formulated Column", "Supplier Code", _
                "Reference", "Amount (£)", "Doc Currency", "Country", "Invoice Number")
    Cols = Array(3, 6, , 7, 5, 8, 9, 11, 4)
    
    Application.ScreenUpdating = False
    
    With wbkActive.Sheets("workings")
        If .AutoFilterMode Then .AutoFilterMode = False
        Set Data = .Range("a1:l" & .Range("a" & .Rows.Count).End(xlUp).Row)
        k = Data.Value2
    End With
    With CreateObject("scripting.dictionary")
        .comparemode = 1
        For i = 2 To UBound(k, 1)
            If Len(k(i, 2)) Then
                s = k(i, 2) & "|" & k(i, 9) & "|" & k(i, 11)
                If Not .exists(s) Then
                    .Add s, Nothing
                End If
            End If
        Next
        k = .keys
    End With
    
    With Data
        For i = 0 To UBound(k)
            x = Split(k(i), "|")
            .AutoFilter 2, x(0), 1
            .AutoFilter 9, x(1), 1
            .AutoFilter 11, x(2)
            FN = .Offset(1).Cells(1, .Columns.Count).Value
            Set wbkNew = Workbooks.Add
            With wbkNew.Sheets(1)
                .Range("a2:a4") = Application.Transpose([{"File Number","Payment/Recovery","Currency"}])
                .Range("a7").Resize(, UBound(Hdr) + 1) = Hdr
                .Range("b2") = FN
                .Range("b3") = x(0)
                .Range("b4") = x(1)
            End With
            On Error Resume Next
            For j = 0 To UBound(Cols)
                .Columns(Cols(j)).Copy wbkNew.Sheets(1).Cells(8, j + 1)
            Next
            On Error GoTo 0
            wbkNew.Sheets(1).Rows(8).Delete
            wbkNew.SaveAs wbkActive.Path & "\" & FN & "-" & x(0) & "-" & x(1) & "-" & x(2), 51
            wbkNew.Close
            Set wbkNew = Nothing
        Next
        .Parent.AutoFilterMode = False
    End With
    Application.ScreenUpdating = True
    
End Sub

HTH

[Admin]

Hi,

You should have mentioned this in your original post. Anyway try this. I assume that you have template file (TemplateName.xltx/TemplateName.xlt) in which on the second sheet you have your calculations.

This code will create a new file based on the template and paste the data on First Sheet.

Sub kTest_v1()
    
    Dim k, Data As Range, x, Hdr, i As Long, Crits, s As String
    Dim wbkActive   As Workbook, wbkNew As Workbook, j As Long
    Dim FN  As String, Cols, TltName   As String
    
    With Application.FileDialog(3)
        .AllowMultiSelect = False
        .Title = "Select the Template File"
        .Filters.Add "Excel Template", ("*.xltx;*.xlt")
        .InitialFileName = ThisWorkbook.Path
        If .Show = -1 Then
            TltName = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    
    Set wbkActive = ThisWorkbook
    
    Hdr = Array("Gateway", "Supplier Code", "Formulated Column", "Supplier Code", _
                "Reference", "Amount (£)", "Doc Currency", "Country", "Invoice Number")
    Cols = Array(3, 6, , 7, 5, 8, 9, 11, 4)
    
    Application.ScreenUpdating = False
    
    With wbkActive.Sheets("workings")
        If .AutoFilterMode Then .AutoFilterMode = False
        Set Data = .Range("a1:l" & .Range("a" & .Rows.Count).End(xlUp).Row)
        k = Data.Value2
    End With
    With CreateObject("scripting.dictionary")
        .comparemode = 1
        For i = 2 To UBound(k, 1)
            If Len(k(i, 2)) Then
                s = k(i, 2) & "|" & k(i, 9) & "|" & k(i, 11)
                If Not .exists(s) Then
                    .Add s, Nothing
                End If
            End If
        Next
        k = .keys
    End With
    
    With Data
        For i = 0 To UBound(k)
            x = Split(k(i), "|")
            .AutoFilter 2, x(0), 1
            .AutoFilter 9, x(1), 1
            .AutoFilter 11, x(2)
            FN = .Offset(1).Cells(1, .Columns.Count).Value
            Set wbkNew = Workbooks.Open(TltName)
            
            With wbkNew.Sheets(1)
                .Range("a2:a4") = Application.Transpose([{"File Number","Payment/Recovery","Currency"}])
                .Range("a7").Resize(, UBound(Hdr) + 1) = Hdr
                .Range("b2") = FN
                .Range("b3") = x(0)
                .Range("b4") = x(1)
            End With
            On Error Resume Next
            For j = 0 To UBound(Cols)
                .Columns(Cols(j)).Copy wbkNew.Sheets(1).Cells(8, j + 1)
            Next
            On Error GoTo 0
            wbkNew.Sheets(1).Rows(8).Delete
            wbkNew.SaveAs wbkActive.Path & "\" & FN & "-" & x(0) & "-" & x(1) & "-" & x(2), 51
            wbkNew.Close
            Set wbkNew = Nothing
        Next
        .Parent.AutoFilterMode = False
    End With
    Application.ScreenUpdating = True
    
End Sub