Suchfunktion innerhalb eines Worksheets

Suchfunktion innerhalb eines Worksheets. Verwendung von Wildcards und AutoFilter
Sub Abfrage1() Ein Modul startet das Formular (VBA für Excel kennt
Abfrage.Show keinen FormLoad-Befehl).
Range("A1").Select Die Zelle A1 des aktiven Arbeitsblattes wird selektiert.
End Sub
Private Sub UserForm_Initialize() Formular "Abfrage" wird initialisiert.
Box2.Text = ActiveSheet.Range("H3").Value Die TextBoxen erhalten den gespeicherten Inhalt zweier
Box1.Text = ActiveSheet.Range("H2").Value Worksheet-Zellen.
Call boxx1
End Sub
Private Sub boxx1() Unterprogramm für einige Steuerelemente.
With Box1
.SelStart = 0
.SelLength = Len(.Text) Die TextBox1 erhält den Fokus.
End With
End Sub
Private Sub aktivieren() Etwas umständliche Rückgabe des Fokus an die
Range("A1").Select "ersten Zellen" des ArbeitsBlattes.
Range("A2").Select
End Sub
Wenn die erste Textbox den Fokus verliert:
Private Sub Box1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Dim ZLinks$, ZRechts$
On Error Resume Next
With Box1
If .Text <> "" Then Wenn Textbox nicht leer ist, dann:
ActiveSheet.Range("H2").Value = .Text - erhält eine Worksheet-Zelle den Inhalt der Textbox.
ZLinks = Left$(.Text, 1) - das linke Zeichen des Suchwortes wird geprüft.
ZRechts = Right$(.Text, 1) - das rechte Zeichen des Suchwortes wird geprüft.
If ZLinks = "*" And ZRechts = "*" Then Wenn bereits Wildcards vorhanden sind, dann:
.Text = ActiveSheet.Range("H2").Value - schreibe den Inhalt der Worksheet-Zelle zurück in
Else die Textbox, - andernfalls:
.Text = "*" & ActiveSheet.Range("H2").Value & "*" - füge dem Suchbegriff zwei Wildcards hinzu.
End If
End If
.SelStart = 0 Beim Verlassen der ersten Textbox wird dieser der
End With Fokus genommen.
End Sub
Private Sub Box2_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Dim ZLinks$, ZRechts$, a$, b$, f%
On Error Resume Next
If Box1.Value = "" Then Wenn Textbox 1 nicht leer ist, dann:
Box1.SetFocus - Rückkehr zu Textbox 1.
Else
With Box2
If .Text <> "" Then Wenn Textbox 2 nicht leer ist, dann:
ActiveSheet.Range("H3").Value = .Text - erhält eine Worksheet-Zelle den Inhalt der Textbox.
ZLinks = Left$(.Text, 1) - das linke Zeichen des Suchwortes wird geprüft.
ZRechts = Right$(.Text, 1) - das rechte Zeichen des Suchwortes wird geprüft.
If ZLinks = "*" And ZRechts = "*" Then Wenn bereits Wildcards vorhanden sind, dann:
.Text = ActiveSheet.Range("H3").Value - schreibe den Inhalt der Worksheet-Zelle zurück in
Else die Textbox, - andernfalls:
.Text = "*" & ActiveSheet.Range("H3").Value & "*" - füge dem Suchbegriff zwei Wildcards hinzu.
End If
Else
ActiveSheet.Range("H3").Value = ""
End If
Selection.Autofilter AutoFilter wird aktiviert.
a = Box1.Text
b = .Text
If optDeutsch.Value = True Then f = 1
If optEnglish.Value = True Then f = 2
If optRoman.Value = True Then f = 3
If optKapitel.Value = False Then Fehler abfangen.
If Len(a) And Len(b) <> 0 Then Selection.Autofilter Field:=f, _
Criteria1:=a, Operator:=xlOr, Criteria2:=b
If Len(b) = 0 Then Selection.Autofilter Field:=f, Criteria1:=a
If Len(a) = 0 Then Box1.SetFocus: Exit Sub
Call aktivieren
End
Else
Exit Sub Nach Verlassen der zweiten Textbox wird das Programm
End If ausgeführt (Suchen mit Autofilter in gewünschter Spalte).
End With Ein CommandButton ist daher nicht mehr notwendig.
End If
End Sub
Private Sub optKapitel_Click() Hier werden die KapitelKöpfe gesucht.
Dim a$, f%
Box2.Text = ""
Box1.Text = "*"
Selection.Autofilter
f = 6
a = Box1.Text
Selection.Autofilter Field:=f, Criteria1:=a
Call aktivieren
End Sub
Private Sub cmdEnde_Click() Beenden des Programms.
Selection.Autofilter
Unload Me
Call aktivieren
End Sub
Private Sub cmdRoLeer_Click() In Spalte RO leere Zellen suchen.
Dim f%, a$, b$
Box2.Text = ""
Box1.Text = ""
Selection.Autofilter
f = 3
a = Box1.Text
b = Box2.Text
Selection.Autofilter Field:=f, Criteria1:=a
Call aktivieren
End
End Sub
Private Sub cmdMappen_Click() Zwischen ArbeitsMappen umschalten.
ActiveWindow.ActivateNext
End Sub
Private Sub cmdLevel_Click() Level suchen.
Dim x$, a$, f%
x = InputBox("Welchen Level suchen Sie?")
If x <> "" Then Selection.Autofilter
f = 4
a = x
Selection.Autofilter Field:=f, Criteria1:=a
Call aktivieren
End
End Sub
Unterprogramm für alle Steuerelemente.
Private Sub entladen(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me 27 = Esc-Taste
If KeyAscii = 2 Then 2 = Strg + b (beenden)
Selection.Autofilter
Unload Me
End If
End Sub
Private Sub cmdSortier_Click() Sortiert das Arbeitsblatt (zuerst Spalte D, dann E).
Selection.Sort Key1:=Range("D2"), Order1:=xlAscending, Key2:=Range("E2"), Order2:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Call aktivieren
End
End Sub
Private Sub UserForm_Terminate() Zwei Worksheet-Zellen erhalten den Inhalt der beiden
ActiveSheet.Range("H2").Value = Box1.Text TextBoxen, wenn das Programm beendet wird.
ActiveSheet.Range("H3").Value = Box2.Text
End Sub
Private Sub Butt1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Call entladen(ByVal KeyAscii) Call Entladen gilt auch für alle anderen Steuerelemente.
End Sub
Private Sub Opt1_Click()
Call boxx1 Call boxx1 gilt auch für alle anderen OptionButton.
Box1.SetFocus
End Sub
Diese Prozedur kopiert den Inhalt aller Arbeitsblätter auf ein neues Blatt:
Private Sub Kopieren()
anzahl = ActiveWorkbook.Worksheets.Count Stellt die Menge der ArbeitsBlätter fest.
ActiveWorkbook.Worksheets.Add Fügt ein neues ArbeitsBlatt hinzu.
ActiveSheet.Name = "Gesamt" Vergibt Namen für neues Arbeitsblatt.
For i = 1 To anzahl + 1 Durchläuft alle Arbeitsblätter (um zu kopieren).
Worksheets(i).Activate Aktiviert ein ArbeitsBlatt nach dem anderen.
If ActiveSheet.Name = "Gesamt" Then GoTo 10 Wenn letztes Blatt erreicht ist, GeheZu Zeile 10.
ActiveCell.CurrentRegion.Select Wählt Bereiche aus.
Selection.Copy Kopiert gewählten Bereich.
Worksheets("Gesamt").Select Wählt neues ArbeitsBlatt aus.
ActiveSheet.Paste Fügt Werte in neues ArbeitsBlatt ein.
ActiveCell.CurrentRegion.Select Wählt Bereich aus.
z = Selection.Rows.Count Zählt die besetzten Zeilen.
Cells(z + 1, 1).Activate Erweitert den Bereich, um Kopiertes dranzuhängen.
10
Next Beendet die Programmschleife.
Range("a1").Select Geht zur Zelle A1.
Abfrage.Show Startet das Formular Abfrage.
End Sub
.
Sponsoren und Investoren

Sponsoren und Investoren sind jederzeit herzlich willkommen!
Wenn Sie die Information(en) auf dieser Seite interessant fanden, freuen wir uns über eine kleine Spende. Empfehlen Sie uns bitte auch in Ihren Netzwerken (z. B. Twitter, Facebook oder Google+). Herzlichen Dank!

Nach oben Sitemap
Impressum & Kontakt