Move rows to new sheets based on 50 unique cell values

[ariffin]

Hi all,

i am currently working on a project where i have a large list of exactly 6030 unique names under the title "Module Name" located under Column A.
I have categorized each row with a name under Column B - total of 51 categories.

i would like to run a macro that would create New sheets based on these 51 categories as well as move or copy the rows to the appropriate sheet.

i am a beginner in terms of macros and i did try to research on the forums for a macro similar to this. i found one where based on the input of a cell value, the row moves the sheet, but the problem is, i have already input this cell value, and to input 6020 rows individually will take a large time.

Any solution is greatly appreciated.

 

[Peter_SSs]

Welcome to the MrExcel board!

Assuming that the sheet you have shown is the left hand (or only) sheet in the workbook, give this macro a try in a copy of that workbook.

Sub CreateDataSheets()
  Dim d As Object
  Dim a As Variant, itm As Variant
 
  Set d = CreateObject("Scripting.Dictionary")
  With Sheets(1)
    a = .Range("B2", .Range("B" & .Rows.Count).End(xlUp)).Value
    For Each itm In a
      d(itm) = Empty
    Next itm
    Application.ScreenUpdating = False
    For Each itm In d.Keys()
      .Copy After:=Sheets(Sheets.Count)
      With Sheets(Sheets.Count).UsedRange
        .AutoFilter Field:=2, Criteria1:="<>" & itm
        .Offset(1).EntireRow.Delete
        .Parent.AutoFilterMode = False
        .Parent.Name = itm
      End With
    Next itm
    Application.ScreenUpdating = True
  End With
End Sub

 

[ariffin]

wow, that worked amazing. there was an error, but i think it is because i had a special character in some of my category name. i will amend the category name and try the code again.
thanks so much, you saved me hours of work.

 

[davesexcel]

Check it out.

Sub Make_Sheets()
    Dim cUnique As Collection
    Dim rng As Range
    Dim c As Range
    Dim sh As Worksheet, WS As Worksheet
    Dim vNum As Variant
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    Set sh = ThisWorkbook.Sheets("Sheet1")
    For Each Sheet In Sheets
        If Sheet.Name <> sh.Name Then Sheet.Delete
    Next Sheet
    
    With sh
        Set rng = .Range("B2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
        Set cUnique = New Collection
        On Error Resume Next
        For Each c In rng.Cells
            cUnique.Add c.Value, CStr(c.Value)
        Next c
        On Error GoTo 0

        For Each vNum In cUnique
            Set WS = ThisWorkbook.Sheets.Add(After:= _
                                             ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))

            WS.Name = vNum
            .Range("A1").AutoFilter Field:=2, Criteria1:=vNum
            rng.Resize(rng.Rows.Count + 1, rng.Columns.Count + 1).Offset(-1, -1).SpecialCells(xlCellTypeVisible).Copy WS.Range("A1")
            .Range("A1").AutoFilter
        Next vNum

    End With
    sh.Select
End Sub

 

[Peter_SSs]

wow, that worked amazing. there was an error, but i think it is because i had a special character in some of my category name. i will amend the category name and try the code again.
thanks so much, you saved me hours of work.

You're welcome.

Yes, special characters could cause a problem, particularly with the naming of the new worksheets.
Let us know if you need anything further.

 

[ariffin]

Works excellent, appreciate both your help