Effiziente Suchfunktion für Datenbank

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Dim arrWerte, bolCode As Boolean, sLast Private Sub UserForm_Initialize() sLast = txtSuche arrWerte = DasArray End Sub Private Sub lbxFund_Click() If Not bolCode Then With lbxFund Worksheets(.Column(0)).Activate Range(.Column(1)).Select End With lbxFund.ListIndex = -1 Hide End If End Sub Private Sub txtSuche_Change() Dim i As Long, j As Integer, oTmp As Object, arrList, oT, n As Long, arrTmp bolCode = True If txtSuche = "" Then lbxFund.Clear sLast = "" Exit Sub End If If sLast "" Then If txtSuche Like sLast & "*" Then arrTmp = lbxFund.List Else arrTmp = arrWerte End If Else arrTmp = arrWerte End If Set oTmp = CreateObject("Scripting.dictionary") j = LBound(arrTmp, 2) For i = LBound(arrTmp) To UBound(arrTmp) If LCase(arrTmp(i, j + 2)) Like "*" & LCase(txtSuche) & "*" Then oTmp(i) = Array(arrTmp(i, j), arrTmp(i, j + 1), arrTmp(i, j + 2)) End If Next If oTmp.Count Then ReDim arrList(1 To oTmp.Count, 1 To 3) For Each oT In oTmp n = n + 1 arrList(n, 1) = oTmp(oT)(0) arrList(n, 2) = oTmp(oT)(1) arrList(n, 3) = oTmp(oT)(2) Next lbxFund.List = arrList sLast = txtSuche Else lbxFund.Clear sLast = "" End If bolCode = False End Sub Private Function DasArray() Dim oCells As Object, wks As Worksheet, rngC As Range Dim oKey, arrTmp, n As Long Set oCells = CreateObject("Scripting.dictionary") For Each wks In Worksheets For Each rngC In wks.UsedRange.Cells If rngC "" Then oCells(rngC) = rngC.Value End If Next Next ReDim arrTmp(1 To oCells.Count, 1 To 3) For Each oKey In oCells n = n + 1 arrTmp(n, 1) = oKey.Parent.Name arrTmp(n, 2) = oKey.Address arrTmp(n, 3) = oCells(oKey) Next DasArray = arrTmp End Function

Private Sub TextBox1_Change() Dim i As Long, j As Integer, oTmp As Object, arrList, oT, n As Long, arrTmp 'Workbooks(Workbookname_WDB).Activate bolCode = True If Frm_Zielsuche.TextBox1 = "" Then Frm_Zielsuche.ListBox1.Clear sLast = "" Exit Sub End If If sLast "" Then If Frm_Zielsuche.TextBox1 Like sLast & "*" Then arrTmp = Frm_Zielsuche.ListBox1.List Else arrTmp = arrWerte End If Else arrTmp = arrWerte End If Set oTmp = CreateObject("Scripting.dictionary") j = LBound(arrTmp, 2) For i = LBound(arrTmp) To UBound(arrTmp) If LCase(arrTmp(i, j + 2)) Like "*" & LCase(Frm_Zielsuche.TextBox1) & "*" Then oTmp(i) = Array(arrTmp(i, j), arrTmp(i, j + 1), arrTmp(i, j + 2)) End If Next If oTmp.Count Then ReDim arrList(1 To oTmp.Count, 1 To 3) For Each oT In oTmp n = n + 1 arrList(n, 1) = oTmp(oT)(0) arrList(n, 2) = oTmp(oT)(1) arrList(n, 3) = oTmp(oT)(2) Next Frm_Zielsuche.ListBox1.List = arrList sLast = Frm_Zielsuche.TextBox1 Else Frm_Zielsuche.ListBox1.Clear sLast = "" End If bolCode = False End Sub

Hallo,
den Fehler erhalte ich auch, wenn ich die Hälfte vom Code weglasse;
Du mußt schon alles einfügen.
Außerdem brauchst Du den Namen der Form nicht im Code ergänzen,
die Objecte beziehen sich ja bereits auf die sie enthaltene Klasse:

Option Explicit
      Dim arrWerte, bolCode As Boolean, sLast
      
      Private Sub UserForm_Initialize()
        sLast = txtSuche
        arrWerte = DasArray
        With lbxFund
            .ColumnCount = 3
            .ColumnWidths = "0;0;"
        End With
      End Sub
      
      Private Sub lbxFund_Click()
        If Not bolCode Then
          With lbxFund
            Worksheets(.Column(0)).Activate
            Range(.Column(1)).Select
          End With
          lbxFund.ListIndex = -1
          Hide
        End If
      End Sub
      
      Private Sub txtSuche_Change()
        Dim i As Long, j As Integer, oTmp As Object, arrList, oT, n As Long, arrTmp
        bolCode = True
        If txtSuche = "" Then
          lbxFund.Clear
          sLast = ""
          Exit Sub
        End If
        If sLast <> "" Then
          If txtSuche Like sLast & "*" Then
            arrTmp = lbxFund.List
          Else
            arrTmp = arrWerte
          End If
        Else
          arrTmp = arrWerte
        End If
        Set oTmp = CreateObject("Scripting.dictionary")
        j = LBound(arrTmp, 2)
        For i = LBound(arrTmp) To UBound(arrTmp)
          If LCase(arrTmp(i, j + 2)) Like "*" & LCase(txtSuche) & "*" Then
            oTmp(i) = Array(arrTmp(i, j), arrTmp(i, j + 1), arrTmp(i, j + 2))
          End If
        Next
        If oTmp.Count Then
          ReDim arrList(1 To oTmp.Count, 1 To 3)
          For Each oT In oTmp
            n = n + 1
            arrList(n, 1) = oTmp(oT)(0)
            arrList(n, 2) = oTmp(oT)(1)
            arrList(n, 3) = oTmp(oT)(2)
          Next
          lbxFund.List = arrList
          sLast = txtSuche
        Else
          lbxFund.Clear
          sLast = ""
        End If
        bolCode = False
      End Sub
      
      Private Function DasArray()
        Dim oCells As Object, wks As Worksheet, rngC As Range
        Dim oKey, arrTmp, n As Long
        Set oCells = CreateObject("Scripting.dictionary")
        For Each wks In Worksheets
          For Each rngC In wks.UsedRange.Cells
            If rngC <> "" Then
              oCells(rngC) = rngC.Value
            End If
          Next
        Next
        ReDim arrTmp(1 To oCells.Count, 1 To 3)
        For Each oKey In oCells
          n = n + 1
          arrTmp(n, 1) = oKey.Parent.Name
          arrTmp(n, 2) = oKey.Address
          arrTmp(n, 3) = oCells(oKey)
        Next
        DasArray = arrTmp
      End Function

Übrigens klasse gemacht von Rudi...!
Gruß,

Guten Tag allerseits
wie auch immer ich es versuche... ich krieg den tollen Code von Rudi nicht in meiner "scharfen" Datenbank zum laufen :-(
Ständig Fehlermeldung
Laufzeitfehler 13 - Typen unverträglich bei der Zeile:
j = LBound(arrTmp, 2)
vielleicht muss ich folgendes erwähnen:
Ich habe natürlich in meiner "scharfen" Datenbank bereits eine relativ aufwendige Userform mit diversen weiteren Feldern, Textboxen, Optionbuttons, etc....
Diese UserForm heisst bei mir Frm_Zielsuche
auf dieser Zielsuche hab ich jetzt mal meine bestehende Listbox1 rausgelöscht und durch eine Listbox mit Namen lbxFund ersetzt.
Ebenso hab ich auf meiner Userform Frm_Zielsuche das bereits bestehende Textfeld rausgelöscht und durch ein Feld mit Namen txtSuche ersetzt.
Den ganzen Code von Rudi hab ich natürlich entsprechend hinter die richtigen Teile meines bereits bestehenden Codes kopiert.
Für mich stellt sich die Frage:
wo genau kommt die Variablen-Deklaration rein ?
in den Allgemeinen Teil oder wo genau ?
Wenn ich dann (nachdem ich alle Code-Teile von Rudi in den bestehenden Code implementiert hab) im txtSuche was reinschreibe so bricht das Teil sofort ab mit Fehler
Laufzeitfehler 13 - Typen unverträglich bei der Zeile:
j = LBound(arrTmp, 2)
Was mach ich falsch ?

Private Function DasArray() Dim oCells As Object, wks As Worksheet, rngC As Range Dim oKey, arrTmp, n As Long Set oCells = CreateObject("Scripting.dictionary") For Each wks In Worksheets For Each rngC In wks.UsedRange.Cells If rngC "" Then Select Case rngC.Column Case 1, 6, 8, 12: oCells(rngC) = rngC.Value End Select End If Next Next ReDim arrTmp(1 To oCells.Count, 1 To 3) For Each oKey In oCells n = n + 1 arrTmp(n, 1) = oCells(oKey) arrTmp(n, 2) = oKey.Parent.Name arrTmp(n, 3) = oKey.Address Next DasArray = arrTmp End Function

Private Function DasArray() Dim oCells As Object, wks As Worksheet, rngC As Range Dim oKey, arrTmp, n As Long Set oCells = CreateObject("Scripting.dictionary") For Each wks In Worksheets For Each rngC In wks.UsedRange.Cells If rngC "" Then Select Case rngC.Column Case 1, 6, 8, 12: oCells(rngC) = rngC.Value End Select End If Next Next ReDim arrTmp(1 To oCells.Count, 1 To 3) For Each oKey In oCells n = n + 1 arrTmp(n, 1) = oKey.Parent.Name arrTmp(n, 2) = oKey.Address arrTmp(n, 3) = oCells(oKey) Next DasArray = arrTmp End Function

Beliebteste Forumthreads (12 Monate)

Arbeitsblatt 'Abkuerzungen'
	B	C	D
1	Fehlermeldung		Bedeutung / Bezeichnung
2	Aw		Aktionsware
3	BLR		Bestell- Lieferrhythmus
4	BV		Bestell-Vorschlag
5	CGR		Geschäftspartner Raiting
6	CPS		Produktions System
7	CTS		Traiding System
8	ELKZ		Endlieferkennzeichen
9	Gui		Graphic User Interface
10	HE		Handelseinheiten
11	Idoc		Intermediate Document
12	LE - WM		Logistics Execution Warehouse Management
13	MM - IM		Material Management Inventory
14	PLU		Public Logistic Unit
15	POS		Point of Sales
16	SBO		Sales Based Ordering

Effiziente Suchfunktion für Datenbank

25
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Effiziente Suchfunktion für Datenbank

25 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

25
Beiträge zum Forumthread

Beiträge zu diesem Forumthread