Macro to Split Data into separate sheets

**zahinullah** · 11-26-2013, 04:05 PM

Hi I have a working macro that takes data and splits it into a worksheet for each number in a column. I can get it to work on a separate sheet with dummy data but not on the actual workbook I use at work. There are numerous other macros working on this worksheet as well as several referenced cells within the segment I am trying to run the macro on. I am not sure if that would cause a problem. The part of the worksheet I want it to run on is E37:J70. The error I am seeing when trying to run is: "Run Time Error 1004 Cannot rename a sheet to the same name as another sheet, a referenced object library or a workbook referenced by Visual Basic."

Another issue is when the data splits the worksheets are ordered backwards with the highest number first and so forth.

Thanks for your help.

Here is the VBA:


Sub Test()
    Dim Sh As Worksheet
    Dim Rng As Range
    Dim c As Range
    Dim List As New Collection
    Dim Item As Variant
    Dim ShNew As Worksheet
    Application.ScreenUpdating = False
'   *** Change Sheet name to suit ***
    Set Sh = Worksheets("Sheet1")
    Set Rng = Sh.Range("E37:E" & Sh.Range("E65536").End(xlUp).Row)
    On Error Resume Next
    For Each c In Rng
        List.Add c.Value, CStr(c.Value)
    Next c
    On Error GoTo 0
    Set Rng = Sh.Range("E6:J" & Sh.Range("E65536").End(xlUp).Row)
    For Each Item In List
        Set ShNew = Worksheets.Add
        ShNew.Name = Item
        Rng.AutoFilter Field:=1, Criteria1:=Item
        Rng.SpecialCells(xlCellTypeVisible).Copy ShNew.Range("A1")
        Rng.AutoFilter
    Next Item
    Set Rng = Selection
    Set c = ActiveCell
     Rng.Sort Key1:=c, Order1:=xlAscending, Header:=xlGuess
    Sh.Activate
    Application.ScreenUpdating = False
    
End Sub

**jaslake** · 11-26-2013, 06:41 PM

Hi zahinullah

Welcome to the Forum!!

It'll probably be something like this (untested as I don't have your Workbook

Sub Test()
    Dim Sh As Worksheet
    Dim Rng As Range
    Dim c As Range
    Dim List As New Collection
    Dim Item As Variant
    Dim ShNew As Worksheet
    Application.ScreenUpdating = False
    '   *** Change Sheet name to suit ***
    Set Sh = Worksheets("Sheet1")
    Set Rng = Sh.Range("E37:E" & Sh.Range("E65536").End(xlUp).Row)
    On Error Resume Next
    For Each c In Rng
        List.Add c.Value, CStr(c.Value)
    Next c
    On Error GoTo 0
    Set Rng = Sh.Range("E6:J" & Sh.Range("E65536").End(xlUp).Row)
    For Each Item In List
        If Not Evaluate("ISREF(" & Item & "!A1)") Then
            Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Item
        Else
            Sheets(Item).Cells.Clear
        End If

        '        Set ShNew = Worksheets.Add
        '                ShNew.Name = Item
        Rng.AutoFilter Field:=1, Criteria1:=Item
        Rng.SpecialCells(xlCellTypeVisible).Copy Sheets(Item).Range("A1")
        Rng.AutoFilter
    Next Item
    Set Rng = Selection
    Set c = ActiveCell
    Rng.Sort Key1:=c, Order1:=xlAscending, Header:=xlGuess
    Sh.Activate
    Application.ScreenUpdating = False

End Sub