Anzeige
Archiv - Navigation
868to872
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
868to872
868to872
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Suchfunktion (per VBA) erweitern

Suchfunktion (per VBA) erweitern
14.05.2007 09:30:15
Andreas

Hallo Excelprofis!
Ich habe wieder mal ein Problem. Ich habe mit Hilfe dieses super Forums ein Userform erstellt, mit dessen Hilfe ich, per Commandbutton "Suchen", nach Werten aus Spalte 2 im Blatt "Auswertung" suchen kann und die dazugehörigen Daten der Zeile werden in der Eingabemaske (Userform) zum bearbeiten angezeigt.
Im Klartext: Ich gebe in "TextBox2" meines Userform Buchstaben ein drücke auf suchen und in einer Listbox (ListBox2) werden alle Einträge mit den gesuchten Anfangsbuchstaben angezeigt. Klicke ich jetzt auf eine Zeile in der ListBox werden die Daten im Userform angezeigt und ich kann Diese mit Hilfe weiterer Schaltflächen bearbeiten, löschen usw.
Dies funktioniert auch super.
Nun zu meinem Problem:
Es kann vorkommen, dass in Spalte 2, im Blatt "Auswertung" nichts steht. In diesem Fall soll die Suche in Spalte 4 des Blattes "Auswertung" fortgesetzt werden.
Ich hoffe, ich habe mich verständlich ausgedrückt und mir kann Jemand helfen.
Danke schon mal für die Hilfe und Mühe!
Hier der Code des Commandbuttons "Suchen".


Private Sub cbSuchen_Click()
Dim r, z As Integer
Dim arrValues() As Variant
If Len(TextBox2) > 0 Then
ListBox2.Visible = True
ListBox2.Clear
ListBox2.Top = ListBox1.Top
ListBox2.Left = ListBox1.Left
ListBox2.Height = ListBox1.Height
ListBox2.Width = ListBox1.Width
With Sheets("Auswertung")
Wert = TextBox2
For r = 8 To .Cells(65536, 2).End(xlUp).Row
Set c = .Cells(r, 2).Find(Wert & "*", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False) _
If Not c Is Nothing Then
ReDim Preserve arrValues(0 To 31, 0 To intRowU)
arrValues(0, intRowU) = .Cells(r, 1)
arrValues(1, intRowU) = .Cells(r, 2)
arrValues(2, intRowU) = .Cells(r, 3)
arrValues(3, intRowU) = .Cells(r, 4)
arrValues(4, intRowU) = .Cells(r, 5)
arrValues(5, intRowU) = .Cells(r, 6)
arrValues(6, intRowU) = .Cells(r, 7)
arrValues(7, intRowU) = .Cells(r, 8)
arrValues(8, intRowU) = .Cells(r, 9)
arrValues(9, intRowU) = .Cells(r, 10)
arrValues(10, intRowU) = .Cells(r, 11)
arrValues(11, intRowU) = .Cells(r, 12)
arrValues(12, intRowU) = .Cells(r, 13)
arrValues(13, intRowU) = .Cells(r, 14)
arrValues(14, intRowU) = .Cells(r, 15)
arrValues(15, intRowU) = .Cells(r, 16)
arrValues(16, intRowU) = .Cells(r, 17)
arrValues(17, intRowU) = .Cells(r, 18)
arrValues(18, intRowU) = .Cells(r, 19)
arrValues(19, intRowU) = .Cells(r, 20)
arrValues(20, intRowU) = .Cells(r, 21)
arrValues(21, intRowU) = .Cells(r, 22)
arrValues(22, intRowU) = .Cells(r, 23)
arrValues(23, intRowU) = .Cells(r, 24)
arrValues(24, intRowU) = .Cells(r, 25)
arrValues(25, intRowU) = .Cells(r, 26)
arrValues(26, intRowU) = .Cells(r, 27)
arrValues(27, intRowU) = .Cells(r, 28)
arrValues(28, intRowU) = .Cells(r, 29)
arrValues(29, intRowU) = .Cells(r, 30)
arrValues(30, intRowU) = .Cells(r, 31)
intRowU = intRowU + 1
End If
Next r
End With
End If
If intRowU <> 0 Then ListBox2.Column = arrValues
End Sub


mfg Andreas

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Suchfunktion (per VBA) erweitern
14.05.2007 15:23:05
Peter Feustel
Hallo Andreas,
so könnte es gehen:


Option Explicit
Private Sub cbSuchen_Click()
Dim r           As Integer
Dim z           As Integer
Dim arrValues() As Variant
Dim Wert        As String
Dim c           As Range
Dim intRowU     As Integer
   If Len(TextBox2) > 0 Then
      ListBox2.Visible = True
      ListBox2.Clear
      ListBox2.Top = ListBox1.Top
      ListBox2.Left = ListBox1.Left
      ListBox2.Height = ListBox1.Height
      ListBox2.Width = ListBox1.Width
      With Sheets("Auswertung")
         Wert = TextBox2
         For r = 8 To .Cells(65536, 2).End(xlUp).Row
            Set c = .Cells(r, 2).Find(Wert & "*", _
               LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
            If Not c Is Nothing Then
               ReDim Preserve arrValues(0 To 31, 0 To intRowU)
               arrValues(0, intRowU) = .Cells(r, 1)
               arrValues(1, intRowU) = .Cells(r, 2)
               arrValues(2, intRowU) = .Cells(r, 3)
               arrValues(3, intRowU) = .Cells(r, 4)
               arrValues(4, intRowU) = .Cells(r, 5)
               arrValues(5, intRowU) = .Cells(r, 6)
               arrValues(6, intRowU) = .Cells(r, 7)
               arrValues(7, intRowU) = .Cells(r, 8)
               arrValues(8, intRowU) = .Cells(r, 9)
               arrValues(9, intRowU) = .Cells(r, 10)
               arrValues(10, intRowU) = .Cells(r, 11)
               arrValues(11, intRowU) = .Cells(r, 12)
               arrValues(12, intRowU) = .Cells(r, 13)
               arrValues(13, intRowU) = .Cells(r, 14)
               arrValues(14, intRowU) = .Cells(r, 15)
               arrValues(15, intRowU) = .Cells(r, 16)
               arrValues(16, intRowU) = .Cells(r, 17)
               arrValues(17, intRowU) = .Cells(r, 18)
               arrValues(18, intRowU) = .Cells(r, 19)
               arrValues(19, intRowU) = .Cells(r, 20)
               arrValues(20, intRowU) = .Cells(r, 21)
               arrValues(21, intRowU) = .Cells(r, 22)
               arrValues(22, intRowU) = .Cells(r, 23)
               arrValues(23, intRowU) = .Cells(r, 24)
               arrValues(24, intRowU) = .Cells(r, 25)
               arrValues(25, intRowU) = .Cells(r, 26)
               arrValues(26, intRowU) = .Cells(r, 27)
               arrValues(27, intRowU) = .Cells(r, 28)
               arrValues(28, intRowU) = .Cells(r, 29)
               arrValues(29, intRowU) = .Cells(r, 30)
               arrValues(30, intRowU) = .Cells(r, 31)
               intRowU = intRowU + 1
            End If
         Next r
      End With
   End If
   If intRowU <> 0 Then
      ListBox2.Column = arrValues
      Exit Sub
    Else
      With Sheets("Auswertung")
         Wert = TextBox2
         For r = 8 To .Cells(65536, 2).End(xlUp).Row
            Set c = .Cells(r, 4).Find(Wert & "*", _
               LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
            If Not c Is Nothing Then
               ReDim Preserve arrValues(0 To 31, 0 To intRowU)
               arrValues(0, intRowU) = .Cells(r, 1)
               arrValues(1, intRowU) = .Cells(r, 2)
               arrValues(2, intRowU) = .Cells(r, 3)
               arrValues(3, intRowU) = .Cells(r, 4)
               arrValues(4, intRowU) = .Cells(r, 5)
               arrValues(5, intRowU) = .Cells(r, 6)
               arrValues(6, intRowU) = .Cells(r, 7)
               arrValues(7, intRowU) = .Cells(r, 8)
               arrValues(8, intRowU) = .Cells(r, 9)
               arrValues(9, intRowU) = .Cells(r, 10)
               arrValues(10, intRowU) = .Cells(r, 11)
               arrValues(11, intRowU) = .Cells(r, 12)
               arrValues(12, intRowU) = .Cells(r, 13)
               arrValues(13, intRowU) = .Cells(r, 14)
               arrValues(14, intRowU) = .Cells(r, 15)
               arrValues(15, intRowU) = .Cells(r, 16)
               arrValues(16, intRowU) = .Cells(r, 17)
               arrValues(17, intRowU) = .Cells(r, 18)
               arrValues(18, intRowU) = .Cells(r, 19)
               arrValues(19, intRowU) = .Cells(r, 20)
               arrValues(20, intRowU) = .Cells(r, 21)
               arrValues(21, intRowU) = .Cells(r, 22)
               arrValues(22, intRowU) = .Cells(r, 23)
               arrValues(23, intRowU) = .Cells(r, 24)
               arrValues(24, intRowU) = .Cells(r, 25)
               arrValues(25, intRowU) = .Cells(r, 26)
               arrValues(26, intRowU) = .Cells(r, 27)
               arrValues(27, intRowU) = .Cells(r, 28)
               arrValues(28, intRowU) = .Cells(r, 29)
               arrValues(29, intRowU) = .Cells(r, 30)
               arrValues(30, intRowU) = .Cells(r, 31)
               intRowU = intRowU + 1
            End If
         Next r
      End With
   End If
   If intRowU <> 0 Then ListBox2.Column = arrValues
End Sub

     Code eingefügt mit Syntaxhighlighter 4.4

Gruß Peter

Anzeige
AW: Suchfunktion (per VBA) erweitern
14.05.2007 21:34:47
Andreas
Hallo Peter!
Dein Code Funktioniert super, Danke! Allerdings ist mir beim Testen aufgefallen, dass ich falsch an das Problem heran gegangen bin.
Wenn in Spalte 2 ein Eintrag, gemäß der Suche, gefunden wird, werden die Einträge ohne Inhalt in Spalte 2 ,aber der Suche entsprechende Einträge in Spalte 4 nicht angezeigt.
Richtig müßte es also sein, daß alle Einträge bei denen in Spalte 2 und alle Einträge bei denen Spalte 2 leer aber in Spalte 4 ein Eintrag gefunden wird, in Listbox2 ausgegeben werden.
Vieleicht kannst du mir dementsprechen noch mal helfen.
Danke für die Hilfe und Mühe!
mfg Andreas

Anzeige
AW: Suchfunktion (per VBA) erweitern
15.05.2007 21:37:49
Peter Feustel
Hallo Andreas,
dann versuch es einmal so:


Option Explicit
Private Sub cbSuchen_Click()
Dim r           As Integer
Dim z           As Integer
Dim arrValues() As Variant
Dim Wert        As String
Dim c           As Range
Dim intRowU     As Integer
   If Len(TextBox2) > 0 Then
      ListBox2.Visible = True
      ListBox2.Clear
      ListBox2.Top = ListBox1.Top
      ListBox2.Left = ListBox1.Left
      ListBox2.Height = ListBox1.Height
      ListBox2.Width = ListBox1.Width
      With Sheets("Auswertung")
         Wert = TextBox2
         For r = 8 To .Cells(65536, 2).End(xlUp).Row
            Set c = .Cells(r, 2).Find(Wert & "*", _
               LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
            If Not c Is Nothing Then
               GoSub Array_fuellen
             Else
               Set c = .Cells(r, 4).Find(Wert & "*", _
               LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
               If Not c Is Nothing Then
                  GoSub Array_fuellen
               End If
            End If
         Next r
      End With
   End If
   If intRowU <> 0 Then ListBox2.Column = arrValues
   Exit Sub  ' das Makro vor der Subroutine hier verlassen !!!
Array_fuellen:
   ReDim Preserve arrValues(0 To 31, 0 To intRowU)
   arrValues(0, intRowU) = .Cells(r, 1)
   arrValues(1, intRowU) = .Cells(r, 2)
   arrValues(2, intRowU) = .Cells(r, 3)
   arrValues(3, intRowU) = .Cells(r, 4)
   arrValues(4, intRowU) = .Cells(r, 5)
   arrValues(5, intRowU) = .Cells(r, 6)
   arrValues(6, intRowU) = .Cells(r, 7)
   arrValues(7, intRowU) = .Cells(r, 8)
   arrValues(8, intRowU) = .Cells(r, 9)
   arrValues(9, intRowU) = .Cells(r, 10)
   arrValues(10, intRowU) = .Cells(r, 11)
   arrValues(11, intRowU) = .Cells(r, 12)
   arrValues(12, intRowU) = .Cells(r, 13)
   arrValues(13, intRowU) = .Cells(r, 14)
   arrValues(14, intRowU) = .Cells(r, 15)
   arrValues(15, intRowU) = .Cells(r, 16)
   arrValues(16, intRowU) = .Cells(r, 17)
   arrValues(17, intRowU) = .Cells(r, 18)
   arrValues(18, intRowU) = .Cells(r, 19)
   arrValues(19, intRowU) = .Cells(r, 20)
   arrValues(20, intRowU) = .Cells(r, 21)
   arrValues(21, intRowU) = .Cells(r, 22)
   arrValues(22, intRowU) = .Cells(r, 23)
   arrValues(23, intRowU) = .Cells(r, 24)
   arrValues(24, intRowU) = .Cells(r, 25)
   arrValues(25, intRowU) = .Cells(r, 26)
   arrValues(26, intRowU) = .Cells(r, 27)
   arrValues(27, intRowU) = .Cells(r, 28)
   arrValues(28, intRowU) = .Cells(r, 29)
   arrValues(29, intRowU) = .Cells(r, 30)
   arrValues(30, intRowU) = .Cells(r, 31)
   intRowU = intRowU + 1
Return
End Sub 

     Code eingefügt mit
Syntaxhighlighter 4.4


Gruß Peter

Anzeige
AW: Suchfunktion (per VBA) erweitern
15.05.2007 22:55:41
Andreas
Hallo Peter!
Danke für die Hilfe. Wenn ich den Code teste bekomme ich eine Fehlermeldung:
Fehler beim Kompilieren:
Unzulässiger oder nicht ausreichend definierter Verweis
Der fett gekennzeichnete Bereich wird markiert.
ReDim Preserve arrValues(0 To 31, 0 To intRowU)
arrValues(0, intRowU) = .Cells(r, 1)
mfg Andreas

AW: Suchfunktion (per VBA) erweitern
16.05.2007 09:10:10
Peter Feustel
Hallo Andreas,
dann so:


Option Explicit
Private Sub cbSuchen_Click()
Dim r           As Integer
Dim z           As Integer
Dim arrValues() As Variant
Dim Wert        As String
Dim c           As Range
Dim intRowU     As Integer
   If Len(TextBox2) > 0 Then
      ListBox2.Visible = True
      ListBox2.Clear
      ListBox2.Top = ListBox1.Top
      ListBox2.Left = ListBox1.Left
      ListBox2.Height = ListBox1.Height
      ListBox2.Width = ListBox1.Width
      With Sheets("Auswertung")
         Wert = TextBox2
         For r = 8 To .Cells(65536, 2).End(xlUp).Row
            Set c = .Cells(r, 2).Find(Wert & "*", _
               LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
            If Not c Is Nothing Then
               GoSub Array_fuellen
             Else
               Set c = .Cells(r, 4).Find(Wert & "*", _
               LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
               If Not c Is Nothing Then
                  GoSub Array_fuellen
               End If
            End If
         Next r
      End With
   End If
   If intRowU <> 0 Then ListBox2.Column = arrValues
   Exit Sub  ' das Makro vor der Subroutine hier verlassen !!!
Array_fuellen:
   With Sheets("Auswertung")
      ReDim Preserve arrValues(0 To 31, 0 To intRowU)
      arrValues(0, intRowU) = .Cells(r, 1)
      arrValues(1, intRowU) = .Cells(r, 2)
      arrValues(2, intRowU) = .Cells(r, 3)
      arrValues(3, intRowU) = .Cells(r, 4)
      arrValues(4, intRowU) = .Cells(r, 5)
      arrValues(5, intRowU) = .Cells(r, 6)
      arrValues(6, intRowU) = .Cells(r, 7)
      arrValues(7, intRowU) = .Cells(r, 8)
      arrValues(8, intRowU) = .Cells(r, 9)
      arrValues(9, intRowU) = .Cells(r, 10)
      arrValues(10, intRowU) = .Cells(r, 11)
      arrValues(11, intRowU) = .Cells(r, 12)
      arrValues(12, intRowU) = .Cells(r, 13)
      arrValues(13, intRowU) = .Cells(r, 14)
      arrValues(14, intRowU) = .Cells(r, 15)
      arrValues(15, intRowU) = .Cells(r, 16)
      arrValues(16, intRowU) = .Cells(r, 17)
      arrValues(17, intRowU) = .Cells(r, 18)
      arrValues(18, intRowU) = .Cells(r, 19)
      arrValues(19, intRowU) = .Cells(r, 20)
      arrValues(20, intRowU) = .Cells(r, 21)
      arrValues(21, intRowU) = .Cells(r, 22)
      arrValues(22, intRowU) = .Cells(r, 23)
      arrValues(23, intRowU) = .Cells(r, 24)
      arrValues(24, intRowU) = .Cells(r, 25)
      arrValues(25, intRowU) = .Cells(r, 26)
      arrValues(26, intRowU) = .Cells(r, 27)
      arrValues(27, intRowU) = .Cells(r, 28)
      arrValues(28, intRowU) = .Cells(r, 29)
      arrValues(29, intRowU) = .Cells(r, 30)
      arrValues(30, intRowU) = .Cells(r, 31)
      intRowU = intRowU + 1
   End With
Return
End Sub 

     Code eingefügt mit
Syntaxhighlighter 4.4


Gruß Peter

Anzeige
Danke für die Hilfe, funktioniert jetzt super!
16.05.2007 11:42:57
Andreas
Hallo Peter!
Vielen Dank für die Hilfe und Mühe, funktioniert super!
mfg Andreas

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige