Name a worksheet after a cell value

[Mark F]

I am hoping to find a way of renaming worksheets based on the contents of cell A1 in all of the sheets

The contents of A1 will be a name eg Fred Bloggs

I want the sheets to be the initials eg FB

There will need to be a check so that if any initials are the same the sheets are named FB1 and FB2 or similar

If possible it would also be good if, once the sheets are renamed they could be moved into alphabetical order (with the second initial being the sort ) ie Bloggs before Brown

I know I am probably pushing my luck a bit!

Appreciate any help / suggestionswhere to start!

Mark

 

[CraigM]

Paste all of this into one module, and run the macro “NameSheets”. Beware, that it is a quick job, and as such contains limited checking routines, and a few quick workarounds. Ie It names the sheets with the first letter of A1, and the first letter after the first space. Therefore, you may encounter trouble if some A1 cells contain only one Name, or three etc.

Sub NameSheets()

For Each sht In Worksheets
    sName = sht.Range("A1")
    i = WorksheetFunction.Find(" ", sName)
    sName = UCase(Left(sName, 1) & Mid(sName, i + 1, 1))
    sFullName = sName
    n = 2
    sht.Name = "XXTempNameXX"
    Do Until Not SheetNameExists(sFullName)
        sFullName = sName & n
        n = n + 1
    Loop
    sht.Name = sFullName
Next sht

For Each sht In Worksheets
    If Len(sht.Name) = 3 Then Worksheets(Left(sht.Name, 2)).Name = Left(sht.Name, 2) & 1
Next sht

SortSheets
End Sub

Function SheetNameExists(ByVal sSheetName As String) As Boolean
SheetNameExists = False
For Each sht In Worksheets
    If sht.Name = sSheetName Then
        SheetNameExists = True
        Exit For
    End If
Next sht
End Function

Private Sub SortSheets()
Application.ScreenUpdating = False
On Error Resume Next

Dim SheetNameArray() As String
ReDim SheetNameArray(1 To Sheets.Count)
sCurrentSheet = ActiveSheet.Name

For x = LBound(SheetNameArray) To UBound(SheetNameArray)
    SheetNameArray(x) = Sheets(x).Name
Next x

QuickSortVariants SheetNameArray

For x = LBound(SheetNameArray) To UBound(SheetNameArray)
    Sheets(SheetNameArray(x)).Move Before:=Sheets(x)
Next x

Sheets(sCurrentSheet).Activate
Application.ScreenUpdating = True
End Sub

Private Sub QuickSortVariants(vArray As Variant, Optional inLow As Long, Optional inHi As Long)
Dim pivot   As Variant
Dim tmpSwap As Variant
Dim tmpLow  As Long
Dim tmpHi   As Long

If inLow = 0 Then inLow = LBound(vArray)
If inHi = 0 Then inHi = UBound(vArray)

    tmpLow = inLow
    tmpHi = inHi
    pivot = vArray((inLow + inHi) / 2)
    
    While (tmpLow <= tmpHi)
        While (vArray(tmpLow) < pivot And tmpLow < inHi)
           tmpLow = tmpLow + 1
        Wend
        While (pivot < vArray(tmpHi) And tmpHi > inLow)
           tmpHi = tmpHi - 1
        Wend
        If (tmpLow <= tmpHi) Then
           tmpSwap = vArray(tmpLow)
           vArray(tmpLow) = vArray(tmpHi)
           vArray(tmpHi) = tmpSwap
           tmpLow = tmpLow + 1
           tmpHi = tmpHi - 1
        End If
    Wend
    
    If (inLow < tmpHi) Then QuickSortVariants vArray, inLow, tmpHi
    If (tmpLow < inHi) Then QuickSortVariants vArray, tmpLow, inHi
End Sub