Learn how to a build a cloud-first strategyRegister Now

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 51
  • Last Modified:

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
0
Shailesh Shinde
Asked:
Shailesh Shinde
  • 3
  • 2
1 Solution
 
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
 
Shailesh ShindeLocalization Engineering & AutomationAuthor Commented:
Attached Error Message screenshot...
1.jpg
0
Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

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

Featured Post

VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

  • 3
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now