Excel macro - Sort by column values and create new excel file

Hi All,
I have an requirement to create separate excel files based upon the unique column (id_sub) values and copy the data into new excel file.
Please find attached sample file for this. The highlighted section means those many new excel file with value as filename.
Can you please provide any reference code for this.

Thanks,
Shail
Book1.xlsx
LVL 3
Shailesh ShindeLocalization Engineering & AutomationAsked:
Who is Participating?
 
Rgonzo1971Connect With a Mentor Commented:
then try

Sub macro()
Dim aIds As Variant
Application.ScreenUpdating = False
Set origSh = ActiveSheet
Worksheets.Add
Set myRng = Range(origSh.Range("B2"), origSh.Range("B" & Rows.Count).End(xlUp))
myRng.Copy Destination:=ActiveSheet.Range("A1")
ActiveSheet.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
aIds = WorksheetFunction.Index(WorksheetFunction.Transpose(Range(Range("A1"), Range("A" & Rows.Count).End(xlUp)).Value), 1, 0)
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
For Each Item In aIds
    Worksheets.Copy

    Range("A1:B1").AutoFilter field:=2, Criteria1:="<>" & Item
    Set myRng = Nothing
    On Error Resume Next
    Set myRng = Range(Range("b2"), Range("b" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    Range("B1").AutoFilter
    If Not myRng Is Nothing Then
        For Idx = myRng.Areas.Count To 1 Step -1
            myRng.Areas(Idx).EntireRow.Delete Shift:=xlUp
        Next
    End If
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "/" & Item
    ActiveWorkbook.Close
Next
Application.ScreenUpdating = True
End Sub

Open in new window

0
 
Rgonzo1971Commented:
Hi,

pls try
Sub macro()
Dim aIds As Variant
Application.ScreenUpdating = False
Set origSh = ActiveSheet
Worksheets.Add
Set myRng = Range(origSh.Range("B2"), origSh.Range("B" & Rows.Count).End(xlUp))
myRng.Copy Destination:=ActiveSheet.Range("A1")
ActiveSheet.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
aIds = WorksheetFunction.Index(WorksheetFunction.Transpose(Range(Range("A1"), Range("A" & Rows.Count).End(xlUp)).Value), 1, 0)
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
For Each Item In aIds
    Worksheets.Copy

    Range("A1:B1").AutoFilter field:=2, Criteria1:="<>" & Item
    Set myRng = Nothing
    On Error Resume Next
    Set myRng = Range(Range("b2"), Range("b" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    Range("B1").AutoFilter
    If Not myRng Is Nothing Then
        For Idx = myRng.Areas.Count To 1 Step -1
            myRng.Areas(Idx).EntireRow.Delete Shift:=xlUp
        Next
    End If
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "/" & Item
    ActiveWorkbook.Close
Next
Application.DisplayAlerts = False
origSh.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Open in new window

Regards
0
 
Shailesh ShindeLocalization Engineering & AutomationAuthor Commented:
Hi,
This works and output the files but show error at "origSh.Delete" line no.31 in your code.

Thanks,
Shail
0
Get expert help—faster!

Need expert help—fast? Use the Help Bell for personalized assistance getting answers to your important questions.

 
Shailesh ShindeLocalization Engineering & AutomationAuthor Commented:
Attached Error Message screenshot...
1.jpg
0
 
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
If you have only one sheet in the workbook, that error will be produced.
Why do you want to delete that original single sheet?
0
 
Shailesh ShindeLocalization Engineering & AutomationAuthor Commented:
Thanks, this works as required.
0
All Courses

From novice to tech pro — start learning today.