Sheet/Tab Sorting

**Airwngr14** · 02-06-2011, 07:00 AM

I'm not sure where to post this.....To start, I've found a lot of good references for macros and formulas on here and never really needed to make a post up until now so I have never registered. Now after searching for weeks, I am not able to find anything to do about having problems sorting sheets so I think it's just me. Here is my problem:
I have a workbook with over 100 sheets and about a little over 80 that are named as last name, first initial (i.e. Smith, J) that need to be alphabetically sorted, BUT all of the referenced macros I have found start and sort but do a weird loop. About 10 at a time are sorted like r through z and then a through d, then back to m through z missing a couple then redoing a through d again. These are the reference macros I have used. The first 2 take like 3 hours each completely sorted (but thats way to long) and the last takes about 15 minutes but then stops after second loop, never really sorting correctly so everything becomes a mess:

Sub SortSheets()

Dim lCount As Long, lCounted As Long
Dim lShtLast As Long
Dim lReply As Long


lReply = MsgBox("To sort Worksheets ascending, select 'Yes'. " _
& "To sort Worksheets descending select 'No'", vbYesNoCancel, "Ozgrid Sheet Sort")
If lReply = vbCancel Then Exit Sub

lShtLast = Sheets.Count

If lReply = vbYes Then 'Sort ascending
For lCount = 1 To lShtLast
For lCount2 = lCount To lShtLast
If UCase(Sheets(lCount2).Name) < UCase(Sheets(lCount).Name) Then
Sheets(lCount2).Move Before:=Sheets(lCount)
End If
Next lCount2
Next lCount


Else 'Sort descending
For lCount = 1 To lShtLast
For lCount2 = lCount To lShtLast
If UCase(Sheets(lCount2).Name) > UCase(Sheets(lCount).Name) Then
Sheets(lCount2).Move Before:=Sheets(lCount)
End If
Next lCount2
Next lCount
End If

Sheets("Control Panel").Move After:=ThisWorkbook.Sheets.Count
Sheets("Matrix").Move After:=ThisWorkbook.Sheets.Count
Sheets("MASTER SHEET").Move After:=ThisWorkbook.Sheets.Count

End Sub
_______________________________________________________________

Sub SortWorksheets()

Dim N As Integer
Dim M As Integer
Dim FirstWSToSort As Integer
Dim LastWSToSort As Integer
Dim SortDescending As Boolean

SortDescending = False

If ActiveWindow.SelectedSheets.Count = 1 Then
    FirstWSToSort = 1
    LastWSToSort = Worksheets.Count
Else
    With ActiveWindow.SelectedSheets
        For N = 2 To .Count
            If .Item(N - 1).Index <> .Item(N).Index - 1 Then
                MsgBox "You cannot sort non-adjacent sheets"
                Exit Sub
            End If
        Next N
        FirstWSToSort = .Item(1).Index
        LastWSToSort = .Item(.Count).Index
     End With
End If

For M = FirstWSToSort To LastWSToSort
    For N = M To LastWSToSort
        If SortDescending = True Then
            If UCase(Worksheets(N).Name) > UCase(Worksheets(M).Name) Then
                Worksheets(N).Move Before:=Worksheets(M)
            End If
        Else
            If UCase(Worksheets(N).Name) < UCase(Worksheets(M).Name) Then
               Worksheets(N).Move Before:=Worksheets(M)
            End If
        End If
     Next N
Next M



End Sub
____________________________________________________________________

Sub SortALLSheets()
  'sort sheets within a workbook in Excel 
  'modified to sort range of sheets
    Dim iSheet As Long, iBefore As Long
    WksName = "INDEX"
    WksName = "MASTER"
  For iSheet = 1 To ActiveWorkbook.Sheets.Count
    For iBefore = 1 To iSheet - 1
      If UCase(Sheets(iBefore).Name) <> UCase(Sheets(iSheet).Name) Then
        ActiveWorkbook.Sheets(iSheet).Move Before:=ActiveWorkbook.Sheets(iBefore)
        Exit For
      End If
    Next iBefore
  Next iSheet
End Sub

What I really want is something quicker than three hours that I can add to another macro, at the end, that creates an employee sheet. Then after creation of the employee sheet and sorting of the other sheets cells I want that new employee sheet to be put into the rest of the other sheets already alphabeticalized. This is the macro I want to add it to that I pieced together:

Sub Add_Employee_2()
'
' Add_Employee_2 Macro
'

'
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Sheets("Control Panel").Select
    Range("I20:K20").Select
    Sheets("Blank, Sheet").Visible = True
    Sheets("Blank, Sheet").Select
'reason to place it before sheets9 is unknown except it puts the new copied sheet far left
    Sheets("Blank, Sheet").Copy Before:=Sheets(9)
    Sheets("Blank, Sheet").Select
    ActiveWindow.SelectedSheets.Visible = False
    Sheets("Matrix").Select
    ThisWorkbook.Application.Run "Show_Pg2_Training_Checklist"
    ThisWorkbook.Application.Run "Show_Pg_3_Trng"
    ThisWorkbook.Application.Run "Show_pg4_matrix"
    ThisWorkbook.Application.Run "Show_pg5_matrix"
    ActiveSheet.Unprotect
    Rows("4:7").Select
    Range("D4").Activate
    Selection.EntireRow.Hidden = False
    Rows("7:7").Select
    Selection.Insert Shift:=xlDown
    Rows("5:5").Select
    Selection.Copy
    Range("A7").Select
    ActiveSheet.Paste
    Range("C7").Select
    Application.CutCopyMode = False
    Range("C7:IE7").Select
    Selection.Replace What:="Blank, Sheet", Replacement:="Blank, Sheet (2)", _
        LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
        False, ReplaceFormat:=False
    Rows("5:5").Select
    Selection.EntireRow.Hidden = True
    Range("A1:C1").Select
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowInsertingRows:=True, AllowDeletingRows:=True, AllowSorting:=True
    Sheets("Blank, Sheet (2)").Select
    Range("A3:C3").Select
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    'Rename the sheet
  


ActiveSheet.Name = InputBox("Type new sheet name (* Preferred Format is the employee last name, first initial i.e. Mechanic, J  * Do not use these characters : /\?*[ or ] in the name and do not leave it blank.")
Range("A3") = InputBox("Type new employee name (* Preferred Format is the employee last name, first name i.e. Mechanic, Joe  * Do not use these characters : /\?*[ or ] in the name and do not leave it blank.")
Range("A5") = InputBox("Type employee job code (* Preferred Format is i.e. MA13, ME13, MS13, etc  * Do not use these characters : /\?*[ or ] in the name and do not leave it blank.")
Range("B5") = InputBox("Type employee number (* Preferred Format is 111111  * Do not use these characters : /\?*[ or ] in the name and do not leave it blank.")
'Sort Names in Matrix
ThisWorkbook.Sheets("Matrix").Unprotect
ThisWorkbook.Sheets("Matrix").Range("Trainining_Certification").Sort Key1:=ThisWorkbook.Sheets("Matrix").Columns("D"), _
Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
ThisWorkbook.Sheets("Matrix").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowInsertingRows:=True, AllowDeletingRows:=True, AllowSorting:=True
ActiveSheet.Select

End Sub

If anyone understands what I'm trying to get at please help me and thank you in advance. If you don't understand I will try to clarify a little bit better

**royUK** · 02-06-2011, 07:25 AM

I would review your workbook & find ways to reduce the number of sheets. It's generally possible to create a table containing all the data then crate a master sheet with lookups to populate from the table

**Airwngr14** · 02-06-2011, 08:21 AM

I wish I could but this the way the company wants it with a sheet per employee but I really thought and stared at all the code and it hit me in the face how simple of a change it is I use the second one but changed it to this and it sorts in less than a minute if I select the sheets that I want to sort manually:

Sub SortWorksheets()

Dim N As Integer
Dim M As Integer
Dim FirstWSToSort As Integer
Dim LastWSToSort As Integer
Dim SortDescending As Boolean

SortDescending = False

If ActiveWindow.SelectedSheets.Count = 1 Then
    FirstWSToSort = 1
    LastWSToSort = Worksheets.Count
Else
    With ActiveWindow.SelectedSheets
        For N = 2 To .Count
            If .Item(N - 1).Index <> .Item(N).Index - 1 Then
                MsgBox "You cannot sort non-adjacent sheets"
                Exit Sub
            End If
        Next N
        FirstWSToSort = .Item(1).Index
        LastWSToSort = .Item(.Count).Index
     End With
End If

For M = FirstWSToSort To LastWSToSort
    For N = M To LastWSToSort
        If SortDescending = True Then
            If UCase(Worksheets(N).Name) > UCase(Worksheets(M).Name) Then
                Worksheets(N).Move After:=Worksheets(M)
            End If
        Else
            If UCase(Worksheets(N).Name) < UCase(Worksheets(M).Name) Then
               Worksheets(N).Move Before:=Worksheets(M)
            End If
        End If
     Next N
Next M

End Sub

But now I have to find a way to add at the beginning of that to select all visible sheets then insert this somewhere for the end result to happen like i want:

Sheets("Control Panel").Move After:=ThisWorkbook.Sheets.Count
Sheets("Matrix").Move After:=ThisWorkbook.Sheets.Count
Sheets("MASTER SHEET").Move After:=ThisWorkbook.Sheets.Count

**Airwngr14** · 02-06-2011, 09:36 AM

Scratch that I figured it out and it works pretty good and quick for a lot of sheets. First sort is slow if it was ascending/descending first then went opposite. Here's my end result:

Sub Add_Employee_2()
'
' Add_Employee_2 Macro
'

'
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Sheets("Control Panel").Select
    Range("I20:K20").Select
    Sheets("Blank, Sheet").Visible = True
    Sheets("Blank, Sheet").Select
    Sheets("Blank, Sheet").Copy After:=Sheets("Control Panel")
    Sheets("Blank, Sheet").Select
    ActiveWindow.SelectedSheets.Visible = False
    Sheets("Matrix").Select
    ThisWorkbook.Application.Run "Show_Pg2_Training_Checklist"
    ThisWorkbook.Application.Run "Show_Pg_3_Trng"
    ThisWorkbook.Application.Run "Show_pg4_matrix"
    ThisWorkbook.Application.Run "Show_pg5_matrix"
    ActiveSheet.Unprotect
    Rows("4:7").Select
    Range("D4").Activate
    Selection.EntireRow.Hidden = False
    Rows("7:7").Select
    Selection.Insert Shift:=xlDown
    Rows("5:5").Select
    Selection.Copy
    Range("A7").Select
    ActiveSheet.Paste
    Range("C7").Select
    Application.CutCopyMode = False
    Range("C7:IE7").Select
    Selection.Replace What:="Blank, Sheet", Replacement:="Blank, Sheet (2)", _
        LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
        False, ReplaceFormat:=False
    Rows("5:5").Select
    Selection.EntireRow.Hidden = True
    Range("A1:C1").Select
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowInsertingRows:=True, AllowDeletingRows:=True, AllowSorting:=True
    Sheets("Blank, Sheet (2)").Select
    Range("A3:C3").Select
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    'Rename the sheet
  


ActiveSheet.Name = InputBox("Type new sheet name (* Preferred Format is the employee last name, first initial eg. Mechanic, J  * Do not use these characters : /\?*[ or ] in the name and do not leave it blank.")
Range("A3") = InputBox("Type new employee name (* Preferred Format is the employee last name, first name eg. Mechanic, Joe  * Do not use these characters : /\?*[ or ] in the name and do not leave it blank.")
Range("A5") = InputBox("Type employee job code (* Preferred Format is eg. MA13, ME13, MS13, etc  * Do not use these characters : /\?*[ or ] in the name and do not leave it blank.")
Range("B5") = InputBox("Type employee number (* Preferred Format is 111111  * Do not use these characters : /\?*[ or ] in the name and do not leave it blank.")
'Sort Names in Matrix
ThisWorkbook.Sheets("Matrix").Unprotect
ThisWorkbook.Sheets("Matrix").Range("Trainining_Certification").Sort Key1:=ThisWorkbook.Sheets("Matrix").Columns("D"), _
Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
ThisWorkbook.Sheets("Matrix").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowInsertingRows:=True, AllowDeletingRows:=True, AllowSorting:=True

'
' Sort sheets ascending alphabetically
'

Dim N As Integer
Dim M As Integer
Dim FirstWSToSort As Integer
Dim LastWSToSort As Integer
Dim SortDescending As Boolean

' select wkshts by selected wksht color due to all wkshts being different colors and to exclude 3 that always show
Dim wsNames() As String
Dim wsColor() As Integer
Dim ws As Worksheet
Dim ind As Integer
  
ReDim wsNames(0)
ReDim wsColor(0)
wsNames(0) = ActiveSheet.Name
wsColor(0) = ActiveSheet.Tab.ColorIndex
  
 For Each ws In ThisWorkbook.Sheets
  If ws.Tab.ColorIndex = wsColor(0) And ws.Visible = xlSheetVisible Then
    ReDim Preserve wsNames(UBound(wsNames) + 1)
    ReDim Preserve wsColor(UBound(wsColor) + 1)
    wsNames(UBound(wsNames)) = ws.Name
    wsColor(UBound(wsColor)) = ws.Tab.ColorIndex
  End If
Next ws

  Sheets(wsNames).Select

' start sort based off selection
SortDescending = False '<-changed this to False

If ActiveWindow.SelectedSheets.Count = 1 Then
    FirstWSToSort = 1
    LastWSToSort = Worksheets.Count
Else
    With ActiveWindow.SelectedSheets
        For N = 2 To .Count
            If .Item(N - 1).Index <> .Item(N).Index - 1 Then
                MsgBox "You cannot sort non-adjacent sheets"
                Exit Sub
            End If
        Next N
        FirstWSToSort = .Item(1).Index
        LastWSToSort = .Item(.Count).Index
     End With
End If

For M = FirstWSToSort To LastWSToSort
    For N = M To LastWSToSort
        If SortDescending = True Then
            If UCase(Worksheets(N).Name) > UCase(Worksheets(M).Name) Then
                Worksheets(N).Move After:=Worksheets(M) '<-changed this to "After"
            End If
        Else
            If UCase(Worksheets(N).Name) < UCase(Worksheets(M).Name) Then
               Worksheets(N).Move Before:=Worksheets(M)
            End If
        End If
     Next N
Next M


End Sub

I do appreciate the suggestion earlier now how to put solved at the top.......

**Marcol** · 02-06-2011, 10:24 AM

This demo workbook might be of some help.
It is for 2007 on but is easy to adapt for earlier versions.

It was originally designed to read the order of the tabs in the workbook as the tabs were dragged to new positions in the book, the results are displayed in sheet "Sheet Index"

1/. Run the Macro "AddSheets"
This generates sheets in the order presented by Column "E", this effectively simulates users adding sheets as required.
The table shows the result as it goes.

2/. Run the Macro "MoveSheetsByName"
Hopefully this sorts the tabs alphbetically A-Z, the option to sort Z-A can easily be added

3/. Drag a sheet to a new position and see the result in column "A"

4/. Run the Macro "DeleteAllSheets"

Hyperlinks could be added to the table Column A to take you to any desired sheet.

Hope this might be of some use to you

**Airwngr14** · 02-07-2011, 11:01 PM

Thanks man I can use this later on for other stuff, but i got it to work like I wanted to by copy and pasting different sources. I should be able to implement this also to kill the redundancy in the workbook. I actually had to do a little more fixing to what I posted but it turned out perfect. Thanks again.