Conditional Split File Based on Row and Column header Values

[patrickrw99]

Hi I Would like to split a source Excel file containing a list of shipment of products to multiple destination per week, so that it can be split into individual excel files based on the destination per week. Screenshot 2022-08-09 092733.png
The output of the above single source file would be 5 separate files:

1. Shipment List to London for Week 1
2. Shipment List to London for Week 2
3. Shipment List to New York for Week 1
4. Shipment List to New York for Week 2
5. Shipment List to Bangkok for Week 2

Screenshot 2022-08-09 093232.png

Would like to know if it is possible to do in Macro and if yes, how the code will be.

Attaching the file as well for your reference. Sample Split File.xlsx
Please do note that this is a dummy sample file, and the real use will be on a bigger data source. But the functions needed are already represented in the file.
Looking forward to the support. Thank you!

[patrickrw99]

Upvoting this Thread, Thanks!

[beyond Excel]

... and the real use will be on a bigger data source.

That is to say: More rows or more columns?...

[patrickrw99]

That is to say: More rows or more columns?...

Yes but its scalable I believe (e.g. more weeks (columns) or more peoducts (rows)

[beyond Excel]

Yes but its scalable I believe (e.g. more weeks (columns) or more peoducts (rows)

Are you absolutely sure that the first four columns will ALWAYS be the same?

And what will be the name of the workbooks to generate?

[patrickrw99]

Are you absolutely sure that the first four columns will ALWAYS be the same?

And what will be the name of the workbooks to generate?

Hi, Sorry for the late reply. yes the first four columns will be the same, the workbook name will be 'Shipment List_Destination_Week#'. Thank you!

[jindon]

Based on your pics.

Assuming the name of the source data sheet is "Sheet1" and the header starts from A1.

Sub test()
    Dim a, e, x, myCode, i As Long, ii As Long, wb As Workbook, r As Range
    Application.ScreenUpdating = False
    Set wb = Workbooks.Add
    With wb.Sheets(1)
        .[a1] = "Shipment Info"
        .[a3] = "Destination"
        .[f3] = "Week:"
        .[a5:c5] = [{"Product Code","Product Description","Amount"}]
    End With
    Set r = ThisWorkbook.Sheets("sheet1").Cells(1).CurrentRegion
    myCode = r.Parent.[unique(filter(a2:b50000,(a2:a50000<>"")*(b2:b50000<>"")))]
    For i = 1 To UBound(myCode, 1)
        If (myCode(i, 1) <> "") * (myCode(i, 2) <> "") Then
            For ii = 5 To r.Columns.Count
                x = Filter(r.Parent.Evaluate("transpose(if((" & r.Columns(1).Address & _
                    "=" & myCode(i, 1) & ")*(" & r.Columns(ii).Address & _
                    "<>0),row(1:" & r.Rows.Count & ")))"), False, 0)
                If UBound(x) > -1 Then
                    a = Application.Index(r.Value, Application.Transpose(x), Array(3, 4, ii))
                    With wb.Sheets(1)
                        .[b2:c2] = Application.Index(myCode, i, 0)
                        .[g3] = Trim$(Replace(r.Cells(1, ii), "Week", ""))
                        .[a5].CurrentRegion.Offset(1).ClearContents
                        .[a6].Resize(UBound(x) + 1, 3) = a
                        .Parent.SaveAs ThisWorkbook.Path & "\" & Join(Array(myCode(i, 1), _
                                myCode(i, 2), r.Cells(1, ii)), "_"), 51
                    End With
                End If
            Next
        End If
    Next
    wb.Close False
    Application.ScreenUpdating = True
End Sub

[patrickrw99]

Based on your pics.

Assuming the name of the source data sheet is "Sheet1" and the header starts from A1.

Sub test()
    Dim a, e, x, myCode, i As Long, ii As Long, wb As Workbook, r As Range
    Application.ScreenUpdating = False
    Set wb = Workbooks.Add
    With wb.Sheets(1)
        .[a1] = "Shipment Info"
        .[a3] = "Destination"
        .[f3] = "Week:"
        .[a5:c5] = [{"Product Code","Product Description","Amount"}]
    End With
    Set r = ThisWorkbook.Sheets("sheet1").Cells(1).CurrentRegion
    myCode = r.Parent.[unique(filter(a2:b50000,(a2:a50000<>"")*(b2:b50000<>"")))]
    For i = 1 To UBound(myCode, 1)
        If (myCode(i, 1) <> "") * (myCode(i, 2) <> "") Then
            For ii = 5 To r.Columns.Count
                x = Filter(r.Parent.Evaluate("transpose(if((" & r.Columns(1).Address & _
                    "=" & myCode(i, 1) & ")*(" & r.Columns(ii).Address & _
                    "<>0),row(1:" & r.Rows.Count & ")))"), False, 0)
                If UBound(x) > -1 Then
                    a = Application.Index(r.Value, Application.Transpose(x), Array(3, 4, ii))
                    With wb.Sheets(1)
                        .[b2:c2] = Application.Index(myCode, i, 0)
                        .[g3] = Trim$(Replace(r.Cells(1, ii), "Week", ""))
                        .[a5].CurrentRegion.Offset(1).ClearContents
                        .[a6].Resize(UBound(x) + 1, 3) = a
                        .Parent.SaveAs ThisWorkbook.Path & "\" & Join(Array(myCode(i, 1), _
                                myCode(i, 2), r.Cells(1, ii)), "_"), 51
                    End With
                End If
            Next
        End If
    Next
    wb.Close False
    Application.ScreenUpdating = True
End Sub

Wow thanks! I will try the code and update to you what I got. Thank you!

[beyond Excel]

Hi. Another way to do it:

Sub Generate_files()
Dim D1, LObj As ListObject, qWeeks As Integer, Line As ListRow, i As Integer, Key, Tmp, j As Integer, mPath$
Application.ScreenUpdating = False
Set D1 = CreateObject("Scripting.Dictionary"): Set LObj = Sheet1.ListObjects(1)
qWeeks = LObj.ListColumns.Count - 4
For Each Line In LObj.ListRows
  For i = 1 To qWeeks
    If Line.Range(4 + i) <> Empty Then
      Key = Join(Array(Line.Range(1), Line.Range(2), Split(LObj.HeaderRowRange(4 + i))(1)), "|")
      If D1.Exists(Key) Then
        Tmp = D1(Key): j = 1 + UBound(Tmp, 2): ReDim Preserve Tmp(1 To 3, 1 To j)
        Tmp(1, j) = Line.Range(3): Tmp(2, j) = Line.Range(4): Tmp(3, j) = Line.Range(4 + i)
        D1(Key) = Tmp
      Else
        D1(Key) = Application.Transpose(Array(Line.Range(3), Line.Range(4), Line.Range(4 + i)))
      End If
    End If
  Next
Next
mPath = ThisWorkbook.Path & "\Breakdown\"
If Dir(mPath, vbDirectory) = "" Then MkDir mPath
If Dir(mPath & "*") <> "" Then Kill mPath & "*"
With Sheet2
  For Each Key In D1.Keys
    .Range("A4:C4") = Split(Key, "|")
    .Range("A6").CurrentRegion.Offset(1).Delete xlShiftUp
    Tmp = Application.Transpose(D1(Key))
    .Range("A6:C6").Offset(1).Resize(UBound(Tmp)) = Tmp
    .Copy
    ActiveWorkbook.SaveAs Filename:=mPath & Replace(Key, "|", "_") & ".xlsx", FileFormat:=51
    ActiveWorkbook.Close False
  Next
End With
Application.ScreenUpdating = True: MsgBox "Finished process."
CreateObject("Shell.Application").ShellExecute mPath
End Sub

[patrickrw99]

Hi. Another way to do it:

Sub Generate_files()
Dim D1, LObj As ListObject, qWeeks As Integer, Line As ListRow, i As Integer, Key, Tmp, j As Integer, mPath$
Application.ScreenUpdating = False
Set D1 = CreateObject("Scripting.Dictionary"): Set LObj = Sheet1.ListObjects(1)
qWeeks = LObj.ListColumns.Count - 4
For Each Line In LObj.ListRows
  For i = 1 To qWeeks
    If Line.Range(4 + i) <> Empty Then
      Key = Join(Array(Line.Range(1), Line.Range(2), Split(LObj.HeaderRowRange(4 + i))(1)), "|")
      If D1.Exists(Key) Then
        Tmp = D1(Key): j = 1 + UBound(Tmp, 2): ReDim Preserve Tmp(1 To 3, 1 To j)
        Tmp(1, j) = Line.Range(3): Tmp(2, j) = Line.Range(4): Tmp(3, j) = Line.Range(4 + i)
        D1(Key) = Tmp
      Else
        D1(Key) = Application.Transpose(Array(Line.Range(3), Line.Range(4), Line.Range(4 + i)))
      End If
    End If
  Next
Next
mPath = ThisWorkbook.Path & "\Breakdown\"
If Dir(mPath, vbDirectory) = "" Then MkDir mPath
If Dir(mPath & "*") <> "" Then Kill mPath & "*"
With Sheet2
  For Each Key In D1.Keys
    .Range("A4:C4") = Split(Key, "|")
    .Range("A6").CurrentRegion.Offset(1).Delete xlShiftUp
    Tmp = Application.Transpose(D1(Key))
    .Range("A6:C6").Offset(1).Resize(UBound(Tmp)) = Tmp
    .Copy
    ActiveWorkbook.SaveAs Filename:=mPath & Replace(Key, "|", "_") & ".xlsx", FileFormat:=51
    ActiveWorkbook.Close False
  Next
End With
Application.ScreenUpdating = True: MsgBox "Finished process."
CreateObject("Shell.Application").ShellExecute mPath
End Sub

Hi, Thank you for the solution, will try this as well.

The Solution from @jindon works great Thank you for all the help