split data into multiple workbooks with 3 conditions.

[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