AW: gezielt in 3 Arbeitsblättern suchen VBA?
13.07.2009 12:25:43
Martin
Hallo Kay,
die gute Nachricht zu Beginn: Ja, das ist möglich! Genau das von Dir beschrieben Vorhaben habe ich bereits (sogar mit 10 Tabellenblättern) umgesetzt. Die schlechte Nachricht: Es ist schon relativ anspruchsvoll.
Einige Tipps zur Umsetzung:
- Gib jedem Datensatz eine individuelle ID (wie in einer Datenbank)
- Sammle Dein Suchergebnis in einem Array und übergib dieses an die Listbox mit den Treffern
Ich gebe Dir meinen Code, der Dir bestimmt sehr weiterhelfen wird:
'-------------------------------------------------------------------------------------------------------------
' Suche starten
'-------------------------------------------------------------------------------------------------------------
Private Sub CommandButton1_Click()
'Bei ScreenUpdating = False flimmern
If ComboBox1 = "" Then ComboBox1 = "*"
'Stnr.-Erkennung -> Keine partiellen Treffer zulassen
If Len(ComboBox1) = 1 Then 'damit manuell umschaltbar
If IsNumeric(ComboBox1) = True Then OptionButton4 = True Else OptionButton1 = True
End If
ListBox1.Clear 'Listbox leeren
Dim Suchbeginn, Suchende
If CheckBox1 = False Then 'Alle Protokolle durchsuchen
Suchbeginn = 1
Suchende = 10
Else
Suchbeginn = ComboBox2.ListIndex + 1
Suchende = ComboBox3.ListIndex + 1
End If
' Suchbereich festlegen
Dim Suchart 'Nur ganzen Inhalt in Zellen suchen oder Fragmentfunde zulassen
If CheckBox2 = False Then Suchart = xlPart Else Suchart = xlWhole
Dim TrefferArr As Variant
Dim Spalten As Integer
ReDim TrefferArr(0 To 8, 1 To 1)
For i = Suchbeginn To Suchende 'Protkolle, in denen gesucht wird
'i = Protokoll index
'Wenn Protokoll unter "Einstellungen" angeklickt ist
If Sheets("Einstellungen").Cells(i + 5, 11) = "Wahr" Then
If Sheets("Wettbewerb " & i).[B7] "" Then 'Wenn mindestens 1 Eintrag im Protokoll _
ist
'Suchbereiche definieren (Vollsuche, Name, Vorname oder Startnr)
Dim Suchbereich As Range
If OptionButton1 = True Then 'Volltext
Set Suchbereich = Sheets("Wettbewerb " & i).Range("Bereich5")
ElseIf OptionButton2 = True Then 'Name
Set Suchbereich = Sheets("Wettbewerb " & i).Range("Nachname")
ElseIf OptionButton3 = True Then 'Vorname
Set Suchbereich = Sheets("Wettbewerb " & i).Range("Vorname")
ElseIf OptionButton4 = True Then 'Startnummer
Set Suchbereich = Sheets("Wettbewerb " & i).Range("startnummern")
Else: MsgBox "Es ist ein Fehler in der Suchbereich-Festlegung aufgreten!", vbOKOnly _
+ vbExclamation, "Fehler in Suchfunktion"
End If
' Suchen und Treffer auflisten
Dim c, firstAddress, lastAddress, Zeit
Dim Treffer As Boolean
With Suchbereich
Set c = .Find(ComboBox1, LookIn:=xlFormulas, lookat:=Suchart) 'muss auf LookIn:= _
xlFormulas stehen, sonst gehen ausgeblendete Zellen nicht
If Not c Is Nothing Then
firstAddress = c.Address
Do
If c.Row & c.Worksheet.Name lastAddress And Not Application. _
Intersect(Sheets("Wettbewerb " & i).Cells(c.Row, c.Column), Sheets("Wettbewerb " & i).Range("Nachname,Vorname,Verein,startnummern")) Is Nothing Then 'Jahrgang kann sich mit Stnr überschneiden
Zeit = c.EntireRow.Cells(1, Sheets("Wettbewerb " & i).Range(" _
Endzeit").Column) 'Endzeit
'If Zeit >= 1 Then Zeit = ""
Treffer = False
'Alle/Finisher/DNF
If ComboBox4.ListIndex = 0 Or (ComboBox4.ListIndex = 1 And Zeit 0 Then
If Treffer = True And c.EntireRow.Cells(1, Sheets(" _
Wettbewerb " & i).Range("SW" & ComboBox5.ListIndex).Column) = "" Then Treffer = False
End If
End If
If Treffer = True Then
If TrefferArr(0, 1) "" Then ReDim Preserve TrefferArr(0 To _
UBound(TrefferArr, 1), 1 To UBound(TrefferArr, 2) + 1)
TrefferArr(0, UBound(TrefferArr, 2)) = c.EntireRow.Cells(1, _
Sheets("Wettbewerb " & i).Range("Nachname").Column) 'Nachname
TrefferArr(1, UBound(TrefferArr, 2)) = c.EntireRow.Cells(1, _
Sheets("Wettbewerb " & i).Range("Vorname").Column) 'Vorname
TrefferArr(2, UBound(TrefferArr, 2)) = c.EntireRow.Cells(1, _
Sheets("Wettbewerb " & i).Range("Verein").Column) 'Verein
TrefferArr(3, UBound(TrefferArr, 2)) = c.EntireRow.Cells(1, _
Sheets("Wettbewerb " & i).Range("NameAK").Column) 'AK
TrefferArr(4, UBound(TrefferArr, 2)) = c.EntireRow.Cells(1, _
Sheets("Wettbewerb " & i).Range("startnummern").Column) 'Startnr.
TrefferArr(5, UBound(TrefferArr, 2)) = i 'Wettbewerb
TrefferArr(6, UBound(TrefferArr, 2)) = c.EntireRow.Cells(1, _
Sheets("Wettbewerb " & i).Range("Jahrgang").Column) 'Jahrgang
TrefferArr(7, UBound(TrefferArr, 2)) = c.EntireRow.Cells(1, _
Sheets("Wettbewerb " & i).Range("Geschlecht").Column) 'w/m
TrefferArr(8, UBound(TrefferArr, 2)) = Zeit 'Endzeit
End If
lastAddress = c.Row & c.Worksheet.Name
End If
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address firstAddress
End If
End With
End If
End If
Next i
'Array transponiert an Listbox übergeben
Dim TrefferArr2()
If UBound(TrefferArr, 2) = 1 Then 'Wenn nur 1 Teilnehmer
ReDim TrefferArr2(1 To 1, 0 To UBound(TrefferArr, 1))
For j = 0 To UBound(TrefferArr, 1)
TrefferArr2(1, j) = TrefferArr(j, 1)
Next j
Else: TrefferArr2 = Application.Transpose(TrefferArr)
End If
If TrefferArr(0, 1) "" Then ListBox1.List() = TrefferArr2
Label4.Caption = "Suchergebnis: " & ListBox1.ListCount & " Treffer"
Label4.Visible = True
ComboBox1.SetFocus
ComboBox1.SelStart = Len(ComboBox1)
ComboBox1.SelLength = Len(ComboBox1)
If ListBox1.ListCount > 0 Then
ListBox1.ListIndex = 0 'Ersten Treffer markieren
Label15.Enabled = True
Else
Label15.Enabled = False
End If
End Sub
Viele Grüße
Martin