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