Aiuto ordine alfabetico celle di più fogli

Public Sub SheetSort19AZ()
'by scossa 2015-01-31

  Dim wb As Workbook
  Dim ws As Worksheet
  Dim wsAct As Worksheet
  Dim rng As Range
  Dim nSheets As Long
  Dim aShNames() As Variant
  Dim aShSorted() As Variant
  Dim j As Long
  Dim k As Long
  Dim re As Object
  Dim reMatch As Object
  Dim nMatch As Long
  Dim nAt As Long
  Dim nLen As Long
  Dim sParsed As String
  Dim sToken As String
  Dim sPatt As String
  Dim nome As String
  Dim sNewName As String
  Dim nStart As Single
  
  On Error GoTo Gest_Exit_
  nStart = Timer
  Set wb = ThisWorkbook
  Set wsAct = wb.ActiveSheet
  nSheets = wb.Sheets.Count
  
  If nSheets = 1 Then
    Err.Raise vbObjectError + 513, Description:="In questa cartella c'è" & vbCrLf & _
      "un solo foglio di lavoro!"
  End If
  
  ReDim aShNames(1 To nSheets, 1 To 2)
  Set re = CreateObject("vbscript.regexp")
  Application.ScreenUpdating = False
  With re
    .Global = True
    sPatt = "d+"
    .IgnoreCase = True
    .Pattern = sPatt
    For Each ws In wb.Sheets
      k = k + 1
      ''''''minuscole in maiuscole
      sNewName = ws.Name
      If Asc(Mid(sNewName, 1, 1)) > 96 And Asc(Mid(sNewName, 1, 1)) < 123 Then
            ws.Name = UCase(sNewName)
      End If
      '''''''''minuscole in maiuscole
      sNewName = ws.Name
      sToken = sNewName
      Set reMatch = .Execute(sToken)
      With reMatch
        nMatch = .Count
        For j = 1 To nMatch
          sParsed = .Item(j - 1).Value
          nAt = .Item(j - 1).FirstIndex + 9 * (j - 1) + (j > 1) + 1
          nLen = .Item(j - 1).Length
          sNewName = Application.Replace(sNewName, nAt, nLen, Right("/////////" & sParsed, 9))
        Next
      End With
      aShNames(k, 2) = ws.Name
      aShNames(k, 1) = sNewName
    Next
    aShSorted = BubbleSrtBi(aShNames)
  End With
  For j = 1 To nSheets
    Debug.Print aShSorted(j, 2) & Application.Rept(" ", 20 - Len(aShSorted(j, 2))) & aShSorted(j, 1)
    wb.Sheets(aShSorted(j, 2)).Move after:=wb.Sheets(nSheets)
  Next
  wsAct.Select
  On Error GoTo 0

Gest_Exit_:
  Application.ScreenUpdating = True

  If Err.Number <> 0 Then
    MsgBox Err.Description, vbCritical, "ERRORE"
  Else
      MsgBox "Elaborazione Effettuta in " & Timer - nStart, vbInformation
  End If
  Set rng = Nothing
  Set wsAct = Nothing
  Set wb = Nothing
  Set re = Nothing
  Set reMatch = Nothing

End Sub


Public Function BubbleSrtBi(ArrayIn)
'by scossa 2015-01-31

  Dim SrtTemp1 As Variant
  Dim SrtTemp2 As Variant
  Dim i As Long
  Dim j As Long
  Dim nLB As Long
  Dim nUB As Long

  nLB = LBound(ArrayIn)
  nUB = UBound(ArrayIn)
  
  For i = nLB To nUB
    For j = i + 1 To nUB
      If ArrayIn(i, 1) > ArrayIn(j, 1) Then
        SrtTemp1 = ArrayIn(j, 1)
        SrtTemp2 = ArrayIn(j, 2)
        ArrayIn(j, 1) = ArrayIn(i, 1)
        ArrayIn(j, 2) = ArrayIn(i, 2)
        ArrayIn(i, 1) = SrtTemp1
        ArrayIn(i, 2) = SrtTemp2
      End If
    Next j
   Next i

  BubbleSrtBi = ArrayIn

End Function