Need to split a LONG list into separate sheets based on repeating, incremental nunbers

Hello all,

This is my first post, so if I've neglected some other more appropriate channel for this question please let me know.

I have a long list of participant numbers, and scores from a particular task, and I need to separate each participant's data into a separate worksheet. Their number repeats throughout the sheet (due to the nature of how I extracted it), and each person has 2 session's worth of data (stored in 2 sets of columns). Any help would be greatly appreciated, as my other option involves lots of cut/copy/pasting...I have attached the workbook in question.


eprime.xls

Hello,

I dont follow what it is exactly your wanting. Can you create one sheet inside of the workbook of what the output should be?

Thanks Mike

Hey,

Here's a version with an 'example' sheet included

eprime_ex.xls

Heres a code and function that will due what you want. The function is to make sure the new sheet name is valid

    Sub CreateSheets()
    Const shName As String = "Sheet1"
    Dim AllCells As Range
    Dim Cell As Range
    Dim NoDupes As New Collection
    Dim i As Integer, j As Integer
    Dim Swap1, Swap2, Item
    Dim lastRow As Long
    
'   Check if autofilter is on. if it is turn it off.
    If Worksheets(shName).AutoFilterMode Then
        Worksheets(shName).Cells.AutoFilter
    End If
    
'   Delete all sheets except Const shName
'   Turn off DisplayAlerts so we dont see the prompt
    Application.DisplayAlerts = False
    For Each ws In Worksheets
        If ws.Name <> shName Then
            ws.Delete
        End If
    Next ws
    Application.DisplayAlerts = True
'   Turn back on DisplayAlerts

'   Find lastrow on Column A
    lastRow = Worksheets(shName).Cells(Rows.Count, "A").End(xlUp).Row
'   Get items are in Column A Starting in row 3
    Set AllCells = Worksheets(shName).Range("A3:A" & lastRow)
'   The next statement ignores the error caused
'   by attempting to add a duplicate key to the collection.
'   The duplicate is not added - which is just what we want!
    On Error Resume Next
    For Each Cell In AllCells
        NoDupes.Add Cell.Value, CStr(Cell.Value)
'       Note: the 2nd argument (key) for the Add method must be a string
    Next Cell

'   Resume normal error handling
    On Error GoTo 0

'   Sort the collection (optional)
    For i = 1 To NoDupes.Count - 1
        For j = i + 1 To NoDupes.Count
            If NoDupes(i) > NoDupes(j) Then
                Swap1 = NoDupes(i)
                Swap2 = NoDupes(j)
                NoDupes.Add Swap1, before:=j
                NoDupes.Add Swap2, before:=i
                NoDupes.Remove i + 1
                NoDupes.Remove j + 1
            End If
        Next j
    Next i
'   Turn off ScreenUpdating. Speeds things up
    Application.ScreenUpdating = False
    Dim iSheetCounter As Integer
'   Now due something with the sorted non-duplicated items
    For Each Item In NoDupes
        iSheetCounter = iSheetCounter + 1
        Application.StatusBar = "Creating Worksheet number:= " & iSheetCounter & " Worksheet Name:= " & Item
'       Add new sheet to the end of workbook and rename sheet
        Worksheets.Add After:=Worksheets(Worksheets.Count)
'       Make sure New sheet name is valid
        ActiveSheet.Name = CleanWorksheetName(CStr(Item))
'       Use autofilter and copy Visible to newly added sheet
        With Worksheets(shName)
            .Range("$A$2:$H$" & lastRow).AutoFilter Field:=1, Criteria1:=Item
            .Cells.SpecialCells(xlCellTypeVisible).Copy Worksheets(CStr(Item)).Range("A1")
        End With
        'Sheets(Item).Columns("D:F").EntireColumn.AutoFit
    Next Item

'   Remove autofilter
    With Worksheets(shName)
        .Select
        .Cells.AutoFilter
    End With

'   Turn back on ScreenUpdating
    With Application
        .StatusBar = False
        .ScreenUpdating = True
    End With
    
'   Clean up
    Set AllCells = Nothing
    Set Cell = Nothing
End Sub
Function CleanWorksheetName(ByRef strName As String) As String
    Dim varBadChars As Variant
    Dim varChar As Variant
     
    varBadChars = Array(":", "/", "\", "?", "*", "[", "]")
     
     'correct string for forbidden characters
    For Each varChar In varBadChars
        Select Case varChar
        Case ":"
            strName = Replace(strName, varChar, vbNullString)
        Case "/"
            strName = Replace(strName, varChar, "-")
        Case "\"
            strName = Replace(strName, varChar, "-")
        Case "?"
            strName = Replace(strName, varChar, vbNullString)
        Case "*"
            strName = Replace(strName, varChar, vbNullString)
        Case "["
            strName = Replace(strName, varChar, "(")
        Case "]"
            strName = Replace(strName, varChar, ")")
        End Select
    Next varChar
     
     'correct string for worksheet length requirement
    strName = Left(strName, 31)
     
    CleanWorksheetName = strName
End Function

It's giving me a
"compile error:
variable undefined"
and selecting the Sub while highlighting 'ws' in this line of code:
" For Each ws In Worksheets "

I inserted a new module and copied the code into it in the VBA editor. Should I have split the Sub from the Function or is this something else?

Add

Dim ws As Worksheet

Im not sure what that problem could be. Maybe your computers memory is lacking because all sheets is held into memory. Also excel 2003 can only have 255 worksheets in workbook.

It very well could be the memory, as I'm not working with that many sheeets, plus these are work computers and are known around the lab for being infamously bad. Thank you so much for your help though, I can figure this out from here!

whoops! I marked it (I think...). thanks for the reminder.