split data into multiple workbooks with 3 conditions.

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

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

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

Quote:

---

Originally Posted by 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

---

Attachment 229Attachment 229

Hi,

Try this.

Code:

---

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

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

Quote:

---

Originally Posted by Admin

Hi,

Try this.

Code:

---

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

---

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.

Code:

---

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

---