Suchergebnis markieren

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
InputBox MsgBox


Excel-Version: 8.0 (Office 97)
nach unten

Betrifft: Suchergebnis markieren
von: Thomas
Geschrieben am: 18.05.2002 - 04:33:31

Hallo, an alle!
Ich moechte in einem Ergebnis aus einem Spezialfilter die entsprechenden Werte farblich markieren, nach denen im Spezialfilter gesucht wurde, oder zumindest die Zellen farblich markieren, in denen die Ergebnisse gefunden wurden.
Der Suchbegriff steht immmer in Zelle $A$60.
Hat jemand eine Idee, wie ich dies mit erreichen kann?
Vielen lieben Dank im voraus.

nach oben   nach unten

Re: Suchergebnis markieren
von: GraFri
Geschrieben am: 18.05.2002 - 06:23:26

GraFriHallo


Option Base 1
Option Compare Text

Dim Tabelle()                    As String
Dim Adresse()                    As String
Dim Anzahl                       As Integer

Sub Suchen_und_anzeigen()
Dim n%, xZelle%, yZelle%
Dim Meldung                      As Byte
Dim Bereich                      As String
Dim Text                         As String
Dim Suchen                       As Variant
Dim TMP                          As Variant
Dim lenTMP                       As Integer
' -------------------------------------------------------------------
' Dieser Abschnitt kann entfallen, wenn von vorhinein der Suchbereich
' deffiniert wird (z.B.: Bereich =Range("A1:T200")
' Bereich festlegen
Bereich = Application.InputBox("Bitte den zu durchsuchenden Bereich" & vbCrLf & _
                   "eingeben (z.B.:  A1:T200)", "Bereich festlegen", "A1:T200", 8)
' -------------------------------------------------------------------

'Suchbegriff festlegen, eventuell anpassen
Suchen = Worksheets("Tabelle1").Range("A60").Value
If Suchen = "" Then Exit Sub

' -------------------------------------------------------------------
' Möglichkeit, Suchbegriff einzugeben
'Suchen = InputBox("Bitte den zu suchenden Wert hier eingeben." & vbCrLf & _
'                  "ENTER ohne Wert = Abbruch", "S U C H M O D U S")
' -------------------------------------------------------------------

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

' letzte Zelle im Bereich ermitteln
With Worksheets(1).Range(Bereich)
    xZelle = .Columns(.Columns.Count).Column
    yZelle = .Rows(.Rows.Count).Row
End With

' Eigentlicher Suchvorgang (in allen Tabellenblättern). Die Adresse der gefundenen
' Zellen wird in Adresse() und das entsprechende Blatt in Tabelle() gespeichert
Anzahl = 1
For n = 1 To Sheets.Count
With Sheets(n).Range(Bereich)
    Set c = .Find(Suchen, After:=Cells(yZelle, xZelle), LookIn:=xlValues)
    If Not Is Nothing Then
        ErsteAdresse = c.Address
        Do
            ReDim Preserve Adresse(Anzahl): ReDim Preserve Tabelle(Anzahl)
' Adresse der Zelle, um einfärben (markieren) rückgängig machen zu können
            Tabelle(Anzahl) = Sheets(n).Name
            Adresse(Anzahl) = c.Address(RowAbsolute:=False, ColumnAbsolute:=False)
' Suchergebnisse rot einfärben
            c.Interior.ColorIndex = 3
            Set c = .FindNext(c)
            Anzahl = Anzahl + 1
        Loop While Not Is Nothing And c.Address <> ErsteAdresse
    End If
End With
Next n

' Anzeige der Suchergebnisse
Text = vbCrLf
For n = 1 To Anzahl - 1
    Text = Text & Tabelle(n) & "  Zelle  " & Adresse(n) & vbCrLf
Next n

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

' Die Anzahl der gefundenen Werte ist (Anzahl - 1), wenn keiner
' gefunden wurde dann ist Anzahl = 1
Select Case Anzahl
Case 1
    Meldung = MsgBox("Es wurde kein übereinstimmender Wert gefunden", _
    vbOKOnly, "G E F U N D E N E   W E R T E")
Case 2
    Worksheets(Tabelle(1)).Select
    ActiveSheet.Range(Adresse(1)).Select
    Meldung = MsgBox("Es wurde eine Übereinstimmung in" & vbCrLf & _
    Text & vbCrLf & "gefunden", vbOKOnly, "G E F U N D E N E   W E R T E")
    Exit Sub
Case Else
    For n = 1 To Anzahl - 1
    Worksheets(Tabelle(n)).Select
    ActiveSheet.Range(Adresse(n)).Select
    Meldung = MsgBox("Drücken Sie JA, um den nächsten gefundenen " & _
    "Wert zu sehen" & vbCrLf & "Insgesamt gibt es " & (Anzahl - 1) & _
    " Übereinstimmungen!" & vbCrLf & Text, vbYesNo, "G E F U N D E N E   W E R T E")
    If Meldung = vbNo Then Exit Sub
    Next n
End Select

End Sub


Sub Markierung_rückgängig()
Dim n%

For n = 1 To Anzahl - 1
    Sheets(Tabelle(n)).Range(Adresse(n)).Interior.ColorIndex = xlNone
Next n
End Sub

mfg, GraFri

 nach oben

Beiträge aus den Excel-Beispielen zum Thema "Suchergebnis markieren"