AW: Suchtreffer hervorheben - wieder altes Format
25.08.2017 12:50:03
Piet
Hallo Steve
ich habe mal probiert die Aufgabe mit gefundene Zelle Farblich markieren zu optimieren. Dann fiel mir auf das es auch farbliche Zellen gibt! Schau mal ob meine Idee "fcOld" alter Farbcode in der Praxis klappt. Das Makro soll den alten Code wiederherstellen. Ich mache aber nach dem Durchlauf keine Wiederholungsabfrage!!
Ich habe die MsgBoxen ein wenig anders programmiert, mit -vbCancel- für kompletten Programm Abbruch.
Dann laueft das Makro nicht durch alle Tabellen. Meine Art Codes zuschreiben untercheidet sich auch von deiner. Ich rücke bei If Then die Syntax ein, damit ich sehe was zu diesem If Then gehört. Besonders wenn mehrere ineinander laufen ist das m.E. übersichtlicher.
Vorsicht vor dem End Befehl !! - dieser Befehl stoppt alle laufenden Makros in allen geöffneten Dateien !!
Wenn du am Arbeitsplatz andere Dateien am laufen hast Finger weg von dem Befehl. - Dann Exit Sub nehmen!!
mfg Piet
'** Warnung vor End Befehl - der löscht alle Excel Makros !!!
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim SSearch As Variant, ok As Variant
Dim c As Object, fcOld As Variant
Dim firstAddress As String
Dim secAddress As Object
SSearch = InputBox("Gib deinen Suchbegriff ein 8-):", "SUCHMASCHINE", SSearch)
If SSearch = "" Then Exit Sub
'** Warnung vor End Befehl - der kitt alle Excel Makros !!!
Anf: 'erneut suchen
For Each ws In Worksheets
With ws.Cells
fcOld = xlNone 'Standard Wert
Set c = .Find(SSearch, LookIn:=xlValues, MatchCase:=False)
If Not c Is Nothing Then
ws.Select
c.Select
fcOld = c.Interior.ColorIndex
c.Interior.ColorIndex = 3
firstAddress = c.Address
Set secAddress = c
ok = MsgBox("Weitersuchen?", vbQuestion + vbYesNoCancel)
'** bei No + Cancel Farbe wiederherstellen !!
If ok = vbNo Or ok = vbCancel Then
c.Interior.ColorIndex = fcOld
If ok = vbCancel Then Exit Sub 'Progr.Abbruch
End If
If ok = vbYes Then 'weiter mit Do Loop
Do
secAddress.Interior.ColorIndex = fcOld
Set c = .FindNext(c)
If c.Address = firstAddress Then Exit Do
Set secAddress = c
c.Select
fcOld = c.Interior.ColorIndex
c.Interior.ColorIndex = 3
ok = MsgBox("Weitersuchen?", vbQuestion + vbYesNoCancel)
If ok = vbCancel Then Exit Sub 'Programmabbruch !!
If ok = vbNo Then Exit Do 'Abbruch Do Loop
Loop Until c.Address = firstAddress
'letzte Zelle immer löschen
secAddress.Interior.ColorIndex = fcOld
End If
End If
End With
Next ws
End Sub