Solved: Arrange sheet by name in between other sheets

[halimi1306]

Hi buddy,

Could some one help me on my code? I have imported 85 sheet to master sheet, however the sheets are not arranged by name type. The result from the code as follow:

01,10,11,12...,19,02,20,21,...,29,03,30,...

it should be like this:
01,02,03,...,09,10,11,12,...,85

Code:


Sub Macro1()
Dim shNames() As String, swOk As Boolean
Dim sh As Worksheet, idx As Integer, i As Integer
Dim shName As String

With ThisWorkbook
ReDim shNames(1 To .Sheets.Count)
For Each sh In .Sheets
idx = idx + 1
shNames(idx) = sh.Name
Next

'sort names
Do
swOk = True
For i = 1 To idx - 1
If shNames(i) > shNames(i + 1) Then
shName = shNames(i)
shNames(i) = shNames(i + 1)
shNames(i + 1) = shName
swOk = False
End If
Next
Loop Until swOk = True

'move sheets
For i = 1 To idx
If i = 1 Then
.Sheets(shNames(i)).Move before:=Sheets(1)
Else
.Sheets(shNames(i)).Move after:=Sheets(i - 1)
End If
Next
End With
End Sub

[Bob Phillips]

Sub Macro1()
Dim shNames() As String, swOk As Boolean
Dim sh As Worksheet, idx As Integer, i As Integer
Dim shName As String

With ThisWorkbook
ReDim shNames(1 To .Sheets.Count)
For Each sh In .Sheets
idx = idx + 1
shNames(idx) = sh.Name
Next

'sort names
Do
swOk = True
For i = 1 To idx - 1
If Format(shNames(i), "000") > Format(shNames(i + 1), "000") Then
shName = shNames(i)
shNames(i) = shNames(i + 1)
shNames(i + 1) = shName
swOk = False
End If
Next
Loop Until swOk = True

'move sheets
For i = 1 To idx
If i = 1 Then
.Sheets(shNames(i)).Move before:=Sheets(1)
Else
.Sheets(shNames(i)).Move after:=Sheets(i - 1)
End If
Next
End With
End Sub

[halimi1306]

hi Xld,

Sorry forgot to mention earlier,

How to arrange my sheets between other sheet. What I mean is that I want to arrange my sheet as follow (Between the Bold":

"Guidelines (Read Only)", "Macro Control (Read Only)", "Summary Dashboard", "Model Engine (Read Only)", (and sheet "01-Innitiative" to "85-Innitiative"), "End"

Thanks for your kind help. :)

http://www.excelforum.com/images/styles/Skylight/misc/progress.gif

[BrianMH]

I'm at work atm but if this isn't solved by the time I'm home tonight (probably will be) I'll have a look.

[halimi1306]

I'm at work atm but if this isn't solved by the time I'm home tonight (probably will be) I'll have a look.

Oh, so sorry Brian. Looks like you're very busy. thanks for your response. Happy working :)

[BrianMH]

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

'Change the 1 to the worksheet you want sorted first
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

Sheets("Guidelines (Read Only)").Move Before:=Sheets(1)
Sheets("Macro Control (Read Only)").Move After:=Sheets(1)
Sheets("Summary Dashboard").Move After:=Sheets(2)
Sheets("Model Engine (Read Only)").Move After:=Sheets(3)

End Sub
A google search of sort worksheets alphabetically returned a top result of
http://www.vbaexpress.com/kb/getarticle.php?kb_id=72

Using that code and then adding 4 lines to bring the worksheets in question back to the beginning does it for you.


OR skipping my little addition you could just select all the sheets that you want to sort and not the ones you want to leave in place.

[halimi1306]

Hi Brian,

Thanks a lots! It works very well.

Thanks :):):)