Vorgänger finden mit Makro
Michael
da ich in größeren Mappen immer die Datenflüsse kontrollieren muss, habe ich mir gestern ein Makro im Internet geladen, dass folgende Aufgabe erfüllt:
Für einen markierten Bereich (mit Werten) werden die Nachfolger(auf anderen Blättern) gesucht und mit Adresse in einem Kommentar in der Zelle hinterlegt.
Das ist schon sehr hilfreich. Ist es nun möglich, die Adressangabe im Kommentar als Hyperlink zu hinterlegen. Meine (bescheidenen) Versuche sind alle gescheitert.
Wenn das mit dem Kommentar nicht gehen sollte, kann man den die Zelle in einem Hyperlink wandeln, der den Vorgänger ansteuert?
Außerdem taucht vor der Adresse immer eine Klammer ([) auf. Wie kriegt man die denn weg?
Vielen Dank für Eure Hilfe!
Gruß
Michael
Hier der Code:
Sub ShowDependents()
'Die Prozedur prüft ob die aktive Zelle (oder die erste
'eines markierten Bereiches) Nachfolge-Zellen hat,
'Werden solche gefunden wird die Zelle eingefärbt und die
'Adressen der Nachfolger werden im Kommentar der Zelle eingetragen.
Dim DependentCellArray() As String
Dim rngFirstCell As Range
Dim rngSelected As Range
Dim rngCell As Range
If TypeName(Selection) = "Range" Then
Set rngFirstCell = ActiveCell
Set rngSelected = Selection
For Each rngCell In Selection
rngSelected.Select
rngCell.Activate
Application.ScreenUpdating = True
If GetDirectDependentsArray(ActiveCell, DependentCellArray) Then
With rngCell
.ClearComments
.AddComment "wird verwendet:" & Chr(10) & _
Join(DependentCellArray, Chr(10))
.Interior.ColorIndex = 35
.Comment.Visible = False
End With
Else
With rngCell
.ClearComments
.Interior.ColorIndex = xlNone
End With
End If
Next
rngSelected.Select
rngFirstCell.Activate
End If
End Sub
Function GetDirectDependentsArray(ThisCell As Range, InArray() As String) _
As Boolean
'' Erzeugt ein Array aller direkten Dependents in allen geöffneten Mappen
'' Input : Eine Zelle (in einem Bereich wird nur die erste Zelle geprüft)
'' : Ein String-Array das die Adressen der Dependents aufniimmt
'' Output : Liefert 'True', wenn mindestens ein Dependent gefunden
'' und das (1 bis X) Array erweitert wurde
'' : Liefert 'False' wenn die Zelle keine Dependents aufweist
'' Das Array wird dann nicht modifiziert
Dim FoundCell As Range
Dim Counter As Integer
Dim WBLen As Integer
Dim FoundCellStr As String
Dim FoundCellAddr As String
''Sicherstellen dass nur eine Zelle geprüft wird
Set ThisCell = ThisCell.Cells(1)
''Den Mappen-Namen ausfiltern
WBLen = Len(ThisCell.Parent.Parent.Name) + 3
Application.ScreenUpdating = False
On Error Resume Next
''Hier werden alle Dependents auf dem Blatt mit der Zelle ausgegeben
FoundCellStr = ThisCell.DirectDependents.Address & Chr(255)
ThisCell.ShowDependents ''Blendet sie Dependents-Pfeile ein
On Error GoTo NoMore
Do
Counter = Counter + 1
''Sucht jede Dependent-Zelle in einer Schleife
Set FoundCell = ThisCell.NavigateArrow(False, 1, Counter)
''Wird eine Zelle auf dem Akiven Tabllenblatt zurückgegebn ist
''die Suche abgesclossen
'' - Externe Zellen werden zuerst angesprungen (wie es scheint)
'' - Fängt auch einen NavigateArrow-Fehler ab, wenn keine Dependents
'' gefunden werden wird die Ausgangszelle ausgegeben
If FoundCell.Parent Is ThisCell.Parent Then Exit Do
''Adresse des Dependents (in externer Schreibweise) ermitteln
FoundCellAddr = FoundCell.Address(False, False, , True) & Chr(255)
If FoundCell.Parent.Parent Is ThisCell.Parent.Parent Then
''Ausfiltern des Mappe-Namens wenn die Dependents in
''derselben Mappe liegen
FoundCellAddr = Mid(FoundCellAddr, WBLen)
End If
FoundCellStr = FoundCellStr & FoundCellAddr
Loop
NoMore:
If FoundCellStr "" Then
''Letzes Chr(255) entfernen
FoundCellStr = Left(FoundCellStr, Len(FoundCellStr) - 1)
InArray = Split(FoundCellStr, Chr(255))
GetDirectDependentsArray = True
End If
''Dependents-Pfeile entfernen. Sind keine da wird kein Fehler erzeugt
ThisCell.ShowDependents Remove:=True
ThisCell.Select
End Function