Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
172to176
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
172to176
172to176
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Suchbegriff FETT markieren!

Suchbegriff FETT markieren!
28.10.2002 08:42:05
Aloisi
Hallo und schönen Tag!

Mit Hilfe einiger Freaks im Forum habe ich vor längerer Zeit eine einfache Datenbank in EX97 angelegt, in welcher ich über einen mit InputBox definierten Suchbegriff abfragen kann.

Alle Datenbankzeilen, in welchen der Suchbegriff vorkommt, werden in einer neuen Tabelle ausgeworfen.

Gibt es eine Möglichkeit, dass jene Textteile der neuen Tabelle, die dem Suchbegriff entsprechen, FETT hinterlegt werden.

Vorweg, herzlichen Dank
Klaus

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Re: Suchbegriff FETT markieren!
28.10.2002 09:45:03
Hajo_Zi
Hallo Klaus

handelt es sich um Werte (es wäre möglich) oder um Formel (es ist nicht möglich)

Warum hast Du den Code nicht mitgepostet??
Sollen wir immer bei Null anfangen??

Gruß Hajo

Re: Suchbegriff FETT markieren!
29.10.2002 10:00:17
Aloisi
Hallo Hajo!

Es handelt sich um Werte!


Sorry, hier der CODE:

Option Explicit
Sub DoppelFilter()
Dim inRoQ As Long, inRoZ As Long, i As Long, eZ As Long
Dim blaNaQ As String, blaNaZ As String
Dim SuBe As Variant
Dim konvSuBe As Variant
On Error GoTo TestError

SuBe = InputBox("Suchbegriff eingeben:" & Chr(10) & " " & Chr(10) & _
"(Das Suchergebnis wird in einem neuen Tabellenblatt angezeigt.)", _
"SUCHABFRAGE")

If SuBe = "" Then
MsgBox "Makro-Abbruch wegen fehlendem Suchbegriff!", , _
"MAKROABBRUCH"
Range("A1").Select
Exit Sub
End If
Application.ScreenUpdating = False
konvSuBe = (UCase(SuBe))
blaNaQ = ActiveSheet.Name
Rows("3:3").Select
Selection.Autofilter
blaNaZ = "Suchergebnis " & konvSuBe
Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = blaNaZ
Sheets(blaNaQ).Select
inRoQ = Cells(Rows.Count, 2).End(xlUp).Row
eZ = 0
For i = 1 To inRoQ Step 1
If InStr(UCase(Cells(i, 3).Value), konvSuBe) > 0 Or _
InStr(UCase(Cells(i, 7).Value), konvSuBe) > 0 Then
eZ = eZ + 1
With Worksheets(Sheets.Count)
inRoZ = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
If eZ = 1 Then inRoZ = 1
.Cells(inRoZ, 1).Value = Cells(i, 1).Value
.Cells(inRoZ, 2).Value = Cells(i, 2).Value
.Cells(inRoZ, 3).Value = Cells(i, 3).Value
.Cells(inRoZ, 4).Value = Cells(i, 4).Value
.Cells(inRoZ, 5).Value = Cells(i, 5).Value
.Cells(inRoZ, 6).Value = Cells(i, 6).Value
.Cells(inRoZ, 7).Value = Cells(i, 7).Value
.Cells(inRoZ, 8).Value = Cells(i, 8).Value
' .Cells(inRoZ, 9).Value = Cells(i, 9).Value
' .Cells(inRoZ, 10).Value = Cells(i, 10).Value
' .Cells(inRoZ, 11).Value = Cells(i, 11).Value
End With
End If
Next i
Sheets(blaNaZ).Select
If eZ = 0 Then
MsgBox _
"Es wurden keine Zellen mit dem Suchbegriff *" & konvSuBe & "* gefunden !", , _
"SUCHERGEBNIS"
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
Sheets(blaNaQ).Select
Rows("3:3").Select
Selection.Autofilter
Range("A4").Select
Else
Sheets(blaNaQ).Select 'Auswertung Formatieren
Rows("1:3").Select
Selection.Copy
Sheets(blaNaZ).Select
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Sheets(blaNaQ).Select
Application.CutCopyMode = False
Rows("3:3").Select
Selection.Autofilter
Columns("A:L").Select
Selection.Copy
Range("A4").Select
Sheets(blaNaZ).Select
Columns("A:L").Select
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("A1:A2").Select
Application.CutCopyMode = False
Selection.End(xlDown).Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1:A2000").Select
Selection.EntireRow.Delete
Range("D4").Select
ActiveWindow.FreezePanes = True
Range("A1:A2").Select
ActiveWindow.DisplayHeadings = False
MsgBox _
"Es wurde(n) " & eZ & " Zeile(n) mit dem Suchbegriff *" & konvSuBe & "* gefunden !" & _
"" & Chr(10) & " " & Chr(10) & _
"Falls das Seiten-Layout für einen Ausdruck eingerichtet werden soll, bestätigen Sie mit OK und drücken Sie anschließend STRG+SHIFT+Q !", , _
"SUCHERGEBNIS"
End If
Application.ScreenUpdating = True
Exit Sub
TestError:
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
Sheets(blaNaQ).Select
Range("A4").Select
MsgBox "Eine Auswertung für den Suchbegriff *" & konvSuBe & "* liegt bereits vor!"
End Sub


Gruß und ein dickes(fettes) Dankeschön
Klaus

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige