AW: Ein Ansatz : JA !
12.10.2009 17:13:02
JogyB
Hi.
Pecedents gibt aber nur die Zellen aus demselben Tabellenblatt an. Für Bezüge zu anderen Tabellenblättern müßte man schauen, ob ein Ausrufezeichen außerhalb zweier Anführungszeichen (dann wäre es ein Text) vorkommt.
Teste mal das:
' testet die Vorgänger auf dem Tabellenblatt,
' ob sie _nicht_ in derselben Zeile sind
Function testPrec(testRng As Range) As Boolean
Dim myPrec As Range
' Überprüfen, ob es sich um eine Formel handelt
If Not testRng.HasFormula Then Exit Function
For Each myPrec In testRng.Precedents
If myPrec.Row testRng.Row Then
testPrec = True
End If
Next
End Function
' Testet auf Bezüge außerhalb des Tabellenblattes
' Sucht in der Formel nach ! außerhalb eines Textblockes
Function testExternal(testRng As Range) As Boolean
Dim endAnf As Long
Dim anF As Long
Dim forMel As String
' Überprüfen, ob es sich um eine Formel handelt
If Not testRng.HasFormula Then Exit Function
forMel = testRng.Formula
' Anführungszeichen, das den vorigen Textbereich beendet
' Zu Beginn natürlich an Stelle 0
endAnf = 0
' Solange außerhalb von Textblöcken prüfen, bis kein
' weitere Anführungszeichen mehr gefunden
Do
' Anführungszeichen nach EndAnf suchen
anF = InStr(endAnf + 1, forMel, """")
' Kein Text in der Formel nach endanf, dann wird ein hypothetisches
' Anführungszeichen nach der Formel zugewiesen,
' damit bis zum Ende getestet wird
If anF = 0 Then anF = Len(forMel) + 1
' zwischen den Anführungszeichen testen
If InStr(Mid(forMel, endAnf + 1, anF - endAnf - 1), "!") 0 Then
testExternal = True
End If
' Anführungszeichen neu bestimmen
endAnf = InStr(anF + 1, forMel, """")
Loop Until endAnf = 0
End Function
' Testet alle Zellen der selektierten Zeile
' Auswahl einer Zelle in der Zeile reicht
Sub testRow()
Dim berEich As Range
Dim zeLLe As Range
' Wenn mehr als eine Zeile markiert, dann abbrechen
If Selection.Rows.Count > 1 Then
Call MsgBox("Bitte nur eine Zeile markieren!", vbCritical, "Fehler!")
Exit Sub
End If
' Gefüllten Bereich in der Zeile bestimmen
With Selection.EntireRow
Set berEich = .Resize(, .Cells(1, Columns.Count).End(xlToLeft).Column)
End With
' Alle testen und ggf. einfärben
For Each zeLLe In berEich.Cells
If testPrec(zeLLe) Or testExternal(zeLLe) Then
zeLLe.Interior.ColorIndex = 46
End If
Next
End Sub
Das Sub ganz unten wird ausgeführt.
Gruss, Jogy