Dividir cada hoja en archivos separados

Sub SplitEachWorksheet()
Dim FPath As String
FPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Sheets
    ws.Copy
    Application.ActiveWorkbook.SaveAs Filename:=FPath & "\" & ws.Name & ".xlsx"
    Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Ordenar las pestañas en orden alfabético

Sub SortWorkBook()
Dim xResult As VbMsgBoxResult
xTitleId = "KutoolsforExcel"
xResult = MsgBox("Sort Sheets in Ascending Order?" & Chr(10) & "Clicking No will sort in Descending Order", vbYesNoCancel + vbQuestion + vbDefaultButton1, xTitleId)
For i = 1 To Application.Sheets.Count
    For j = 1 To Application.Sheets.Count - 1
        If xResult = vbYes Then
            If UCase$(Application.Sheets(j).Name) > UCase$(Application.Sheets(j + 1).Name) Then
                Sheets(j).Move after:=Sheets(j + 1)
            End If
            ElseIf xResult = vbNo Then
                If UCase$(Application.Sheets(j).Name) < UCase$(Application.Sheets(j + 1).Name) Then
                    Application.Sheets(j).Move after:=Application.Sheets(j + 1)
            End If
        End If
    Next
Next
End Sub

Remover acentos

Function ACENTOS(thestring As String)
Dim A As String * 1
Dim B As String * 1
Dim i As Integer
Const AccChars = "ŠŽšžŸÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖÙÚÛÜÝàáâãäåçèéêëìíîïðñòóôõöùúûüýÿ"
Const RegChars = "SZszYAAAAAACEEEEIIIIDNOOOOOUUUUYaaaaaaceeeeiiiidnooooouuuuyy"
For i = 1 To Len(AccChars)
A = Mid(AccChars, i, 1)
B = Mid(RegChars, i, 1)
thestring = Replace(thestring, A, B)
Next
StripAccent = thestring
End Function

Function QUITARACENTOS(cadena As String) As String
  Dim posicion As Long
  Const conAcento As String = "áéíóúÁÉÍÓÚ"
  Const sinAcento As String = "aeiouAEIOU"
  For i = 1 To Len(conAcento)
    cadena = Replace(cadena, Mid(conAcento, i, 1), Mid(sinAcento, i, 1))
  Next i
  QUITARACENTOS = cadena
End Function

INICIALES

Function INICIALES(texto As Range) As String
    Dim resultado As String
    Dim palabras() As String
    palabras = Split(AjustarEspacios(texto))
    For i = LBound(palabras) To UBound(palabras)
        resultado = resultado & Left(palabras(i), 1)
    Next
    INICIALES = resultado
End Function

Private Function AjustarEspacios(ByVal texto As String) As String
    Dim resultado As String  
    resultado = Trim(texto)
    Do While InStr(resultado, "  ")
        resultado = Replace(resultado, "  ", " ")
    Loop
    AjustarEspacios = resultado
End Function