Thema Datum  Von Nutzer Rating
Antwort
09.04.2024 22:24:53 Bosse
NotSolved
10.04.2024 00:00:09 xlKing
NotSolved
10.04.2024 08:11:27 Bosse
NotSolved
10.04.2024 19:11:35 ralf_b
NotSolved
10.04.2024 19:47:39 xlKing
NotSolved
10.04.2024 19:49:22 xlKing
NotSolved
Rot via Repository innerhalb der XLSM
11.04.2024 12:09:19 Trägheit
NotSolved
23.04.2024 22:04:51 Nobody
NotSolved

Ansicht des Beitrags:
Von:
Trägheit
Datum:
11.04.2024 12:09:19
Views:
207
Rating: Antwort:
  Ja
Thema:
via Repository innerhalb der XLSM

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

 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:

 
 

  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen