Export to new workbooks based on two columns

[YasserKhalil]

Hello everyone

I have the following code that exports new workbooks based on the unique values in column I (column = 9)
The values in column 9 are 1 - 2 - 3

Code: Select all

Sub Test()
    Const iColHeader As Long = 9
    Dim a, ws As Worksheet, dic As Object, header As Range, i As Long
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
        With shCT.Cells(1).CurrentRegion
            .Parent.Select: .Parent.AutoFilterMode = False
            Set header = .Columns(iColHeader)
            Set ws = ThisWorkbook.Sheets.Add(ThisWorkbook.Sheets(1))
            Set dic = CreateObject("Scripting.Dictionary")
            dic.CompareMode = 1
            a = .Columns(header(1).Column).Value
            For i = 2 To UBound(a, 1)
                If Not dic.Exists(a(i, 1)) Then
                    dic(a(i, 1)) = Empty
                    .AutoFilter header.Column, a(i, 1)
                    .Copy ws.Cells(1)
                    ws.Name = a(i, 1)
                    ws.Copy
                    With ActiveWorkbook
                        With .Worksheets(1)
                            .Name = "Sheet1"
                            .DisplayRightToLeft = True
                            .Columns.AutoFit
                            .Columns(iColHeader).Delete
                        End With
                        .SaveAs ThisWorkbook.Path & "\" & a(i, 1), 51
                        .Close False
                    End With
                    Sheets(1).Cells.Clear
                    .AutoFilter
                End If
            Next i
            ws.Delete
            Application.Goto .Range("A1")
        End With
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "Exported Successfully", 64
End Sub

How can I add another column (say column K) to be added as another criterion
the values in column K are 2 - 9

so the new workbooks should be
1 - 2.xlsx
1 - 9.xlsx
2 - 2.xlsx
2 - 9.xlsx
3 - 2.xlsx
3 - 9.slxs

I have posted the question at this link too
https://www.excelforum.com/excel-progra ... ost5773122

[HansV]

Since you didn't attach a sample workbook, I cannot test the code.

Code: Select all

Sub Test()
    Const iColHeader As Long = 9
    Const iColHeader2 As Long = 11
    Dim a
    Dim a2
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim dic As Object
    Dim header As Range
    Dim header2 As Range
    Dim i As Long
    Dim s As String
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set wb = Workbooks.Add(xlWBATWorksheet)
    Set ws = wb.Worksheets(1)
    ws.Name = "Sheet1"
    ws.DisplayRightToLeft = True
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    shCT.AutoFilterMode = False
    With shCT.Cells(1).CurrentRegion
        Set header = .Columns(iColHeader)
        a = header.Value
        Set header2 = .Columns(iColHeader2)
        a2 = header2.Value
        For i = 2 To UBound(a, 1)
            s = a(i, 1) & " - " & a2(i, 1)
            If Not dic.Exists(s) Then
                dic(s) = Empty
                .AutoFilter iColHeader, a(i, 1)
                .AutoFilter iColHeader2, a2(i, 1)
                .Copy ws.Cells(1)
                With ws
                    .Columns(iColHeader2).Delete
                    .Columns(iColHeader).Delete
                    .Columns.AutoFit
                End With
                wb.SaveAs ThisWorkbook.Path & "\" & s, xlOpenXMLWorkbook
                ws.Cells.Clear
                .AutoFilter
            End If
        Next i
        wb.Close SaveChanges:=False
        Application.Goto .Range("A1")
    End With
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "Exported Successfully", vbInformation
End Sub

[YasserKhalil]

Amazing. Thank you very much for great help all the time.