AW: Verknüpfte Tabellenblätter einblenden
20.03.2009 20:47:25
Jogy
Hi.
Mir ist noch ein Fehler aufgefallen: Wenn in der Formel ein ! in Anführungszeichen steht, dann liest es falsch aus.
Korrektur:
' Liest die Namen der Tabellenblätter aus einer Formel heraus
' Rückgabewert ist Array mit den Tabellenblattnamen von 1 bis ...
' Ist Obergrenze des Arrays 0, dann wurde nichts gefunden
' Sollte mit allen Namen gehen
' ggf. müssen mögliche Zeichen, die nicht zu ' um den Namen führen, noch
' in regex.pattern ergänzt werden
' externe Verweise werden ignoriert
Function getVerweise(myRange As Range) As String()
Dim regEx As New RegExp
Dim myMatches As MatchCollection
Dim myMatch As Match
Dim tempFormel() As String
Dim tableNames() As String
Dim tempString As String
Dim i As Long
Dim startPos As Long
Dim tempName As String
Dim checkName
Dim douBlette As Boolean
Dim zeLLe As Range
' Array vordimensionieren, 0 damit es nachher erkennbar ist,
' ob schon Werte geschrieben wurden
ReDim tableNames(0 To 0)
' Groß/Klein egal
regEx.IgnoreCase = True
' Suchmuster: ^ bedeutet "alles außer"
regEx.Pattern = "[^0-9a-zäöü_]"
' Soll den kompletten String durchsuchen
regEx.Global = True
For Each zeLLe In myRange
' Wenn Formel vorhanden und ! (sonst kein Bezug auf anderes Blatt) in der Formel,
' dann Bearbeiten
If zeLLe.HasFormula And InStr(zeLLe.Formula, "!") 0 Then
' Es könnten jetzt noch ! in "" stehen, die müssen entfernt werden
If InStr(zeLLe.Formula, """") 0 Then
tempFormel = Split(zeLLe.Formula, """")
' Jedes 2. Element (ungerade) des Datenfeldes ist zwischen "", dort ! ersetzen
For i = 1 To (UBound(tempFormel) - 1) / 2
tempFormel(2 * i - 1) = Replace(tempFormel(2 * i - 1), "!", "")
Next
' Wieder zusammensetzen
tempString = Join(tempFormel, """")
Else
tempString = zeLLe.Formula
End If
' Wenn kein ! mehr vorhanden, dann muss nichts gemacht werden
If InStr(tempString, "!") 0 Then
' Nach ! aufteilen (kommt in jedem Bezug zu anderm Blatt vor)
tempFormel = Split(tempString, "!")
For i = 0 To UBound(tempFormel) - 1
' Wenn in Hochkommas
If Right(tempFormel(i), 1) = "'" Then
' voriges Hochkomma suchen
startPos = InStrRev(Left(tempFormel(i), Len(tempFormel(i)) - 1), "'") + _
1
' Wenn nach diesem ' ein [ kommt, ist es ein externer Bezug
' also nur weiter, wenn das nicht der Fall ist
If InStr(startPos, tempFormel(i), "[") = 0 Then
tempName = Mid(tempFormel(i), startPos, Len(tempFormel(i)) - _
startPos)
End If
' Wenn nicht in Hochkommas
Else
' Suche mit Regexp
Set myMatches = regEx.Execute(tempFormel(i))
' regEx.Pattern = "[^0-9a-zäöü_]"
' Set myMatches = regEx.Execute("äcc#ddd#ddd#")
' Wenn was gefunden, dann die Position des letzten gefundenen Zeichens
' +2, da ab 0 gezählt wird und das erste zu verwertende Zeichen gesucht
If Not myMatches Is Nothing Then
startPos = myMatches(myMatches.Count - 1).FirstIndex + 2
' Ansonsten soll ab erstem Zeichen übertragen werden
Else
startPos = 1
End If
' Speichert Namen zwischen
tempName = Right(tempFormel(i), Len(tempFormel(i)) - startPos + 1)
End If
' Wenn was in Tempname steht,
If tempName "" Then
' Auf Doubletten testen
douBlette = False
For Each checkName In tableNames
If checkName = tempName Then
douBlette = True
Exit For
End If
Next
' und wenn es keine ist, Array vergrößern und Wert übergeben
If Not douBlette Then
If UBound(tableNames) = 0 Then
ReDim tableNames(1 To 1)
Else
ReDim Preserve tableNames(1 To UBound(tableNames) + 1)
End If
tableNames(UBound(tableNames)) = tempName
End If
End If
tempName = ""
Set myMatches = Nothing
Next
End If
End If
Next
' Rückgabewert
getVerweise = tableNames
End Function
Gruss, Jogy