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