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 (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

229229

[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