Man kann innerhalb einer Excel-Mappe Informationen als XML speichern; diese sind nicht direkt sichtbar. Den Umgang damit, könnte man in einer Klasse kapseln - hier NameRepository.

So wäre es zum Beispiel auch möglich, eine art Historie der Namensänderungen mitsamt demjenigen der sie umbenannt hat zu führen - z.B. kann man sich die letzten 10 Änderungen merken und das ohne das diese Liste direkt einsehbar ist. Sogar ein Undo-Feature wäre denkbar... usw. etc. pp

Grüße

Ein Anwendungsbeispiel folgt weiter unten.

'Klasse: NameRepository
Option Explicit

Private Const REPO_XML_NAMESPACE = "my-project.company.com"
Private Const REPO_VERSION = "1.0"

Private Const NODE_WKS = "worksheet"
Private Const ATTR_CODENAME = "codename"
Private Const ATTR_NAME = "name"
Private Const ATTR_OLDNAME = "oldname"

Private m_objLocalRepo As Office.CustomXMLPart

Public Function GetName(Worksheet As Excel.Worksheet) As String
  GetName = GetNameInternal(Worksheet)
End Function

Public Function AddOrUpdate(Worksheet As Excel.Worksheet, NewName As String) As String
  AddOrUpdate = AddOrUpdateInternal(Worksheet, NewName)
End Function

Public Sub Clear()
  Call ClearInternal
End Sub

Private Sub EnsureInitialized()
  Call InitializeRespository
End Sub

Private Function GetNameInternal(Worksheet As Excel.Worksheet) As String
  
  Call EnsureInitialized
  
  Dim xmlNode As Office.CustomXMLNode
  Set xmlNode = m_objLocalRepo.DocumentElement.SelectSingleNode("./" & NODE_WKS & "/@" & ATTR_NAME)
  
  If Not xmlNode Is Nothing Then
    GetNameInternal = xmlNode.Text
  Else
    GetNameInternal = vbNullString
  End If
  
End Function

Private Function AddOrUpdateInternal(Worksheet As Excel.Worksheet, NewName As String) As String
  
  Call EnsureInitialized
  
  With m_objLocalRepo.DocumentElement
    
    Dim xmlNode As Office.CustomXMLNode
    Set xmlNode = .SelectSingleNode("./" & NODE_WKS & "[@" & ATTR_CODENAME & "='" & Worksheet.CodeName & "']")
    
    If Not xmlNode Is Nothing Then
      
      Dim strName As String
      strName = xmlNode.SelectSingleNode("./@" & ATTR_NAME).Text
      xmlNode.SelectSingleNode("./@" & ATTR_OLDNAME).Text = strName
      xmlNode.SelectSingleNode("./@" & ATTR_NAME).Text = NewName
      
      AddOrUpdateInternal = strName
      
    Else
      
      Call .AppendChildNode(Name:=NODE_WKS)
      With .SelectSingleNode("./" & NODE_WKS & "[last()]")
        Call .AppendChildNode(NodeValue:=Worksheet.CodeName, NodeType:=msoCustomXMLNodeAttribute, Name:=ATTR_CODENAME)
        Call .AppendChildNode(NodeValue:=NewName, NodeType:=msoCustomXMLNodeAttribute, Name:=ATTR_NAME)
        Call .AppendChildNode(NodeValue:=Worksheet.Name, NodeType:=msoCustomXMLNodeAttribute, Name:=ATTR_OLDNAME)
      End With
      
      AddOrUpdateInternal = Worksheet.Name
      
    End If
    
  End With
  
End Function

Private Sub ClearInternal()
  Call EnsureInitialized
  Do While m_objLocalRepo.DocumentElement.ChildNodes.Count > 0
    Call m_objLocalRepo.DocumentElement.ChildNodes(1).Delete
  Loop
End Sub

Private Sub InitializeRespository()
  
  If m_objLocalRepo Is Nothing Then
    With ThisWorkbook.CustomXMLParts
      
      With .SelectByNamespace(REPO_XML_NAMESPACE)
        If .Count > 0 Then
          Set m_objLocalRepo = .Item(1)
          Exit Sub
        End If
      End With
      
      Set m_objLocalRepo = .Add("<repo xmlns=""" & REPO_XML_NAMESPACE & """ version=""" & REPO_VERSION & """/>")
      
    End With
  End If
  
End Sub

Der nachfolgende Code dient nur zur Demonstration.

Hinweis: Das Makro zählt zur Veranschaulichung automatisch Indizes hoch. Es kann dabei natürlich zu Kollisionen kommen, was ich hier jetzt nicht abfange. Darum teste das am besten in einer leeren Mappe welche nur zwei Blätter beinhaltet "Tabelle1" und "Tabelle3".

Option Explicit

Sub Demo()
    
  Dim objRepo As NameRepository
  Set objRepo = New NameRepository
  
  Dim wks As Excel.Worksheet
  Dim strPrevName As String
  Dim strNewName As String
  
  For Each wks In ThisWorkbook.Worksheets
    'erzeugt neuen Namen
    strNewName = GenNewName(wks.Name)
    'setzt den neuen Namen
    wks.Name = strNewName
    'sichert den Namen und gibt den alten Namen zurück
    strPrevName = objRepo.AddOrUpdate(wks, strNewName)
    
    Debug.Print wks.CodeName; ": "; """"; strPrevName; """"; " -> "; """"; strNewName; """"
  Next
  
End Sub

Private Function GenNewName(Name As String) As String
  Dim vntId As Variant
  vntId = ExtractId(Name)
  If IsError(vntId) Then
    GenNewName = Name & "1"
  Else
    GenNewName = Left$(Name, Len(Name) - Len(CStr(vntId))) & vntId + 1
  End If
End Function

Private Function ExtractId(Expression As String) As Variant
  
  Dim char As String * 1
  Dim i As Long
  
  For i = Len(Expression) To 1 Step -1
    char = Mid$(Expression, i, 1)
    If Not ("0" <= char And char <= "9") Then
      Exit For
    End If
  Next
  
  If i < Len(Expression) Then
    ExtractId = CLng(Mid(Expression, i + 1))
  Else
    ExtractId = CVErr(xlErrNA)
  End If
  
End Function