Re: Mehrfache Suchergebnisse über mehrere Tabellen
08.03.2003 08:56:48
Nepumuk
Hallo Anita,
wie wäre es damit?
In das Klassenmodul "Diese Arbeitsmappe":
Dieser Code schafft einen neuen Eintrag im Menü Bearbeiten.Option Explicit
Private Sub Workbook_Open()
Dim objCtr As CommandBarPopup, objBtn As CommandBarButton
Set objCtr = Application.CommandBars("Worksheet Menu Bar").FindControl(ID:=30003)
Do
On Error Resume Next
objCtr.Controls("Suchen Kennziffer" & Space(30) & "Strg+Q").Delete
Loop Until Err.Number <> 0
On Error Goto 0
Set objBtn = objCtr.Controls.Add(Type:=msoControlButton, Temporary:=True)
With objBtn
.Caption = "Suchen Kennziffer" & Space(30) & "Strg+Q"
.OnAction = "Suchen"
End With
Application.OnKey "^{Q}", "Suchen"
Application.OnKey "^{q}", "Suchen"
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim objCtr As CommandBarPopup
Set objCtr = Application.CommandBars("Worksheet Menu Bar").FindControl(ID:=30003)
Do
On Error Resume Next
objCtr.Controls("Suchen Kennziffer" & Space(30) & "Strg+Q").Delete
Loop Until Err.Number <> 0
Application.OnKey "^{Q}"
Application.OnKey "^{q}"
End Sub
Code eingefügt mit Syntaxhighlighter 1.14
In ein "normales Modul":
Option Explicit
Option Base 1
Dim anzahl As Long, feld() As String
Public Sub suchen()
Dim zellen As Range, Suchbegriff As Variant, Adresse As String
Dim index As Integer, zähler As Long
anzahl = 0
Suchbegriff = Application.InputBox("Bitte die gewünschte Kennziffer eingeben", "Eingabe")
If Suchbegriff <> False And Suchbegriff <> "" Then
Sheets(4).Cells.Clear
For index = 1 To 3
With Sheets(index).Range("A1:A65536")
Set zellen = .Find(What:=Suchbegriff, LookAt:=xlWhole)
If Not zellen Is Nothing Then
Adresse = zellen.Address
Do
zähler = zähler + 1
ReDim Preserve feld(zähler)
feld(zähler) = zellen.Row
Set zellen = .FindNext(zellen)
Loop While Not zellen Is Nothing And zellen.Address <> Adresse
Call sortieren(1, UBound(feld))
Call zeig(index, feld())
zähler = 0
End If
End With
Next
End If
Sheets(4).Activate
End Sub
Private Sub zeig(Tabelle As Integer, feld() As String)
Dim zeile As Long, index As Long
For zeile = anzahl + 1 To anzahl + UBound(feld)
index = index + 1
Sheets(Tabelle).Range("A" & feld(index) & ":F" & feld(index)).Copy Sheets(4).Cells(zeile, 1)
Next
anzahl = anzahl + UBound(feld)
End Sub
Private Sub sortieren(Untergrenze As Long, Obergrenze As Long)
Dim index1 As Long, index2 As Long, Element As String, Zwischenspeicher As Long
index1 = Untergrenze
index2 = Obergrenze
Zwischenspeicher = CLng(Mid(feld(((Untergrenze + Obergrenze) / 2) \ 1), InStr(2, feld(((Untergrenze + Obergrenze) / 2) \ 1), "$") + 1))
Do
Do While CLng(Mid(feld(index1), InStr(2, feld(index1), "$") + 1)) < Zwischenspeicher
index1 = index1 + 1
Loop
Do While Zwischenspeicher < CLng(Mid(feld(index2), InStr(2, feld(index2), "$") + 1))
index2 = index2 - 1
Loop
If index1 <= index2 Then
Element = feld(index1)
feld(index1) = feld(index2)
feld(index2) = Element
index1 = index1 + 1
index2 = index2 - 1
End If
Loop Until index1 > index2
If Untergrenze < index2 Then Call sortieren(Untergrenze, index2)
If index1 < Obergrenze Then Call sortieren(index1, Obergrenze)
End Sub
Code eingefügt mit Syntaxhighlighter 1.14
Gruß
Nepumuk