Hatte schon nicht mehr mit dir gerechnet,...
20.06.2007 00:19:25
Luc:-?
..., Bernd,
deshalb ein Nachtrag ins Archiv! Hier die VBA-Prozedur mit Bsp für eine Rufprozedur zu einer _
bestimmten Zellenfarbe (falls du die Fehlerzellen auch noch farblich direkt markierst - nicht mit bedingter Formatierung!). Aber diese Fktnalitität müsstest du ohnehin selbst programmieren (s.u.):
Sub FmZGold()
Call FZelle("Gold")
End Sub
Sub FZelle(Optional ByVal ZFarbe As Variant)
Static Mappe As String, Blatt As String, fz As String, _
l As Long, ft As Boolean, y As Range
Dim a(1) As Variant, b(1) As Variant, FZA As String, _
FTyp As Boolean, i As Integer, j As Integer, m As Integer, _
c As Long, k As Long, r As Long, x As Range, z As Range, _
mp As XlMousePointer
On Error GoTo fx
a(0) = Array("angezeigten", "angezeigter", "angezeigte")
a(1) = Array("markierten", "markierte", "markierte")
b(0) = Array("Fehlerwerte", "Fehlerwert", "Fehlerwerte")
b(1) = Array("Fehlerzellen", "Fehlerzelle", "Fehlerzellen")
FTyp = Not IsMissing(ZFarbe)
i = Abs(CInt(FTyp))
mp = Application.Cursor
With ActiveWorkbook
If .Name Mappe Then
Mappe = .Name: Blatt = ""
End If
End With
Application.Cursor = xlWait
Selection.SpecialCells(xlCellTypeLastCell).Select
With ActiveSheet
If .Name Blatt Then
Blatt = .Name: ft = FTyp: fz = "": l = 0
With Selection
c = lastCol("A1:" & .Address(0, 0), -1)
r = lastRow("A1:" & .Address(0, 0), -1)
End With
If c = 0 Or r = 0 Then
Set y = .Cells(1, 1): GoTo ex
End If
Set y = .Cells(r, c)
ElseIf FTyp ft Then
ft = FTyp: fz = "": l = 0
End If
If fz "" Then GoTo ex
For Each x In .Range(.Cells(1, 1), y)
If Left(x.Formula, 1) "=" Then GoTo nx
If FTyp Then
If ColNtoN(x.Interior.Color) = ZFarbe Then
fz = fz & IIf(fz = "", "", " ") & x.Address(0, 0)
End If
ElseIf IsError(x.Value) Then
fz = fz & IIf(fz = "", "", " ") & x.Address(0, 0)
ElseIf Left(x.Value, 1) = "#" And _
(Right(x.Value, 1) = "!" Or InStr(x.Value, "! ")) Then
fz = fz & IIf(fz = "", "", " ") & x.Address(0, 0)
ElseIf Left(x.Value, 1) = "F" And InStr(x.Value, ": ") And _
IsNumeric(PartOf(x.Value, "F", ": ")) _
Then
fz = fz & IIf(fz = "", "", " ") & x.Address(0, 0)
End If
nx: Next x
ex: k = ListOp(fz, "cnt", , " "): j = IIf(k > 1, 2, k)
FZA = IIf(k = 0, "Keine", k) & " "
If Between(l, 1, k - 1) Then
m = 6
Else
m = MsgBox(FZA & a(i)(j) & " " & b(i)(j) & " gefunden!" & Chr(10) & IIf(k = 0, _
"", "Zellen" & IIf(k = l, "anzeige beendet!", " zeigen [Ja] bzw. " & _
"angeben [Nein]?")), IIf(k = 0, vbOKOnly, IIf(k = l, vbAbortRetryIgnore, _
vbYesNoCancel)), "Fehlersuche in '[" & Mappe & "]" & Blatt & "'!" & _
.Cells(1, 1).Address(0, 0) & IIf(c * r = 0, "", ":" & y.Address(0, 0)))
End If
Select Case m
Case 5, 7
MsgBox IIf(Len(fz)
Die roten Codeteile musst du durch eigene Konstruktionen ersetzen, wenn du den ursprünglichen Leistungsumfang aufrecht erhalten willst, oder den entsprechenden Part sinnvoll entfernen. Die entsprechenden Codepassagen haben ff. Aufgaben:
- ColNtoN(x.Interior.Color) → Wandelt die Zellfarbe der Zelle x in einen Farbnamen um, der mit der Eingabe vgl wird - Ersatz: Zellfarbe als Zahlenwert (in Rufprozedur) angeben - kann auch entfallen!
- PartOf(x.Value, "F", ": ") → Falls im Wert der Zelle x eine Fehlerbezeichnung der Art F0000: enthalten ist, wird hier diese Fehlernr ermittelt - Ersatz: mit Mid, Instr und Vergleichen (kompliziert!) - kann entfallen, da sehr speziell!
- ListOp(fz, "cnt", , " ") → Die udFkt ermittelt die Anzahl der durch Leerzeichen getrennten Elemente der Zeichenkette fz - Ersatz: Mit Do-While-Schleife Leerzeichen in fz zählen und 1 addieren - kann evtl entfallen, dann aber k Festwert zuweisen!
- Between(l, 1, k - 1) → Ermittelt, ob l zwischen 1 und k-1 liegt - Ersatz: ≥1 und ≤k-1 - kann evtl entfallen (→ListOp)?
So, dann viel Spaß beim Anpassen!
Gruß Luc :-?
PS: Wenn du den Code kopierst, vergiss nicht, anschließend die HTML-Farbtags und die von der Forumssoftware zusätzlich eingefügten "_" zu entfernen!