VBA Macro To Rearrange 150 Sheets Based on a List in a Column

[Jambi46n2]

I have 150 sheets inside 1 workbook, they need to be ordered exactly as listed in a column on a separate sheet.

Example (SheetA, SheetB, SheetC, ect)

These sheets have been renamed, and every macro I've found online is re-ordering based on the "Sheets Property (Name)" not by the actual naming convention listed in Excel.

I was hoping the code below would work, but it shorts by the property of the sheet, not the actual sheet name.

Any suggestions are greatly appreciated.

Thank you!

Sub SortWS()
' Assumes Source Listing is Already sorted
' If source Listing is not sorted additional coding will be
' needed to sort the source listing first
' There is no error checking so if the sheet name does not match the source list
' you will get an error if it attempts to move a sheet that doesnt exist


Dim ActiveWB As String
ActiveWB = ActiveWorkbook.Name                                                  'Capture Active Workbook Name
Dim SourceWB As Workbook
Dim SourceSH As String


Application.ScreenUpdating = False                                              'Turn ScreenUpdating OFf so its transparent


Set SourceWB = Workbooks.Open("F:\Finance Projects\BizNet Report\Chris\lists.xlsx", False, True)                      'Set the Source workbook Change the file Location
SourceSH = "Sheet1"                                                              'Set the Source Sheet Name


LastRow = SourceWB.Worksheets(SourceSH).Cells(Rows.Count, "A").End(xlUp).Row    'Determines Last Row based on column A if the names are a different column change A to appropriate column
ReDim SheetNames(LastRow)                                                       'Sets Array based on Number of Sheets
For T = 1 To LastRow
    SheetNames(T) = SourceWB.Worksheets(SourceSH).Cells(T, 1)                   'Read the sheet names in based on the Sourcesheet.  Assumes names are in Column A on source sheet Change the 1 to appropriate column
Next T
SourceWB.Close False                                                            ' close the source workbook without saving changes


Workbooks(ActiveWB).Activate                                                    'Make Sure workbook is active
Application.ScreenUpdating = True                                               'Turn Screen Updating on


For I = 1 To LastRow
For T = I To LastRow


If SheetNames(T) < Worksheets(I).Name Then Worksheets(SheetNames(T)).Move Before:=Worksheets(I)
Next T
Next I


End Sub

 

[mikerickson]

If you replace Worksheets(i).Name with Worksheets(i).CodeName, it should work the way you want.

 

[mikerickson]

These sheets have been renamed, and every macro I've found online is re-ordering based on the "Sheets Property (Name)" not by the actual naming convention listed in Excel.

I was hoping the code below would work, but it shorts by the property of the sheet, not the actual sheet name.

I think you are looking for the codename property of the sheets. The Code Name is given when the sheet is created, doesn't change and is found in the .CodeName property of a Sheet object. The Tab Name is what appears on the screen, can be changed by the user and is found in the .Name property of a Sheet object.

This link explains the different ways to refer to sheets, https://www.mrexcel.com/forum/excel...ksheets-info-reference-loop-add-etcetera.html

As to sorting according to a given list, this routine will do that.
The initial sections to assign the range of cells with the list and and the book whose sheets are to be reorder should be adjusted to match your situation.
NOTE: the function SheetCodeNamed acceses the .VBProject property of a workbook and your permissions may be set to forbid such access. IF that is the case, the AltSheetCodeNamed function should be used. (Its a little slower.)

Sub SortByList()
    Dim rngListOfNames As Range, arrListOfNames
    Dim wbBookToReorder As Workbook
    Dim wsSheetToMove As Worksheet
    Dim i As Long
    
    Rem set workbook whose sheets are to be re-ordered
    Set wbBookToReorder = Workbooks("Workbook1.xlsm")
    
    Rem set workbook with list of sheets
    With Workbooks("Workbook2.xlsm").Sheets("Sheet1")
        Set rngListOfNames = Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
    End With
        ' if re-ordering the list (e.g. alphabetic sorting) is desired, do it here
    arrListOfNames = Application.Transpose(rngListOfNames.Value)
    
    Application.ScreenUpdating = False
    
    Rem sort the sheets according to list
    For i = UBound(arrListOfNames) To LBound(arrListOfNames) Step -1
        Set wsSheetToMove = SheetCodeNamed(arrListOfNames(i), wbBookToReorder)
        If Not wsSheetToMove Is Nothing Then
            wsSheetToMove.Move before:=wbBookToReorder.Sheets(1)
        End If
    Next i
    
    Application.ScreenUpdating = True
End Sub

Function SheetCodeNamed(SheetCodeName As Variant, wb As Workbook) As Worksheet
    On Error Resume Next
    With wb
        Set SheetCodeNamed = .Sheets(.VBProject.VBComponents(SheetCodeName).Properties("index"))
    End With
    On Error GoTo 0
End Function

Function AltSheetCodeNamed(SheetCodeName As Variant, wb As Workbook) As Worksheet
    Dim oneSheet As Worksheet
    For Each oneSheet In wb.Sheets
        If LCase(oneSheet.CodeName) = LCase(SheetCodeName) Then
            Set AltSheetCodeNamed = oneSheet
            Exit Function
        End If
    Next oneSheet
End Function

Note that SortByList will put the sheets in the order of the list, whatever that order is.

If you want the sheets to be ordered alphabeticaly, a shorter code will do that, no list required. (No SheetCodeNamed function needed either)

Sub SortSheetsAlphabeticalyByCodeName()
    Dim wbBookToSort As Workbook
    Dim i As Long, j As Long
    
    Set wbBookToSort = Workbooks("Workbook1.xlsm")
    Application.ScreenUpdating = False
    
    With wbBookToSort
        For i = 2 To .Sheets.Count
            For j = 1 To i - 1
                If .Sheets(i).CodeName < .Sheets(j).CodeName Then
                    .Sheets(i).Move before:=.Sheets(j)
                End If
            Next j
        Next i
    End With
    
    Application.ScreenUpdating = True
End Sub

 

[Jambi46n2]

Thank you both for the prompt reply.

Unfortunately, I've had no luck with the code suggestions above.

The objective is to arrange the sheets by the actual sheet name displayed in the excel tab, not the property (Name).

They aren't listed alphabetically, they need to be arranged specifically to a separate workbook in column A which lists all the sheet names (tab names).

I appreciate the assistance.

 

[Fluff]

Is this what you want.

Sub SortWS()
   Dim ActiveWB As Workbook, SourceWB As Workbook
   Dim Ary As Variant
   Dim i As Long

   Application.ScreenUpdating = False
   Set ActiveWB = ActiveWorkbook
   Set SourceWB = Workbooks.Open("c:\Mrexcel\+book1.xlsm") '("F:\Finance Projects\BizNet Report\Chris\lists.xlsx", False, True)
   
   With SourceWB.Worksheets("Sheet1")
      Ary = .Range("A2", Range("A" & Rows.Count).End(xlUp)).Value2
   End With
   SourceWB.Close False
   
   With ActiveWB
      For i = 1 To UBound(Ary)
         .Sheets(Ary(i, 1)).Move .Sheets(i)
      Next i
   End With
End Sub

 

[Jambi46n2]

Is this what you want.

Sub SortWS()
   Dim ActiveWB As Workbook, SourceWB As Workbook
   Dim Ary As Variant
   Dim i As Long

   Application.ScreenUpdating = False
   Set ActiveWB = ActiveWorkbook
   Set SourceWB = Workbooks.Open("c:\Mrexcel\+book1.xlsm") '("F:\Finance Projects\BizNet Report\Chris\lists.xlsx", False, True)
   
   With SourceWB.Worksheets("Sheet1")
      Ary = .Range("A2", Range("A" & Rows.Count).End(xlUp)).Value2
   End With
   SourceWB.Close False
   
   With ActiveWB
      For i = 1 To UBound(Ary)
         .Sheets(Ary(i, 1)).Move .Sheets(i)
      Next i
   End With
End Sub

Fluff!! You've saved the day yet again! Wow you've bailed me out of so many binds these past few weeks.

I can't thank you enough, and everyone else for your time!

 

[Fluff]

You're welcome & thanks for the feedback