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:
228
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.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
'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".

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
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