Bestimmte Zelle Suchen und Auflisten

[claudia]

Hallo ich habe folgendes Problemchen, so sieht ungefähr meine Tabelle aus:

SpalteA.......SpalteB
GKZ..........Typ

7W08.........Art 1 Z ohne R
7W23.........Art 1 Z ohne R
7S09.........Art 1 Z ohne R
7S73.........Art 1 Z ohne R
7S99.........Art 1 Z ohne R
7W23.........Art 2 X mit R

in der Zelle E1 wird der gesuchte Wert eingeben und in F1 wieder der zugehörige Typ ausgegeben.
Meine Suchfunktion funktioniert soweit das wenn der gesuchte Wert gefunden wurde der Typ ausgegeben wird. Jedoch kommt in SpalteA 7W23 zweimal vor, ich möchte aber folgende Ausgabe:
Wenn nach 7W23 gesucht wird soll der Typ in der Spalte F untereinander aufgelistet werden
7W23 Art1 Z ohne R
Art 2 X mit R

Mein Code:

Code:

Sub ZeileFinden()
Dim Ergebnis As Range

Set Ergebnis = Tabelle1.Columns(1).Find(what:=Tabelle1.Range("E1").Value, _
                lookat:=xlWhole)

If Ergebnis Is Nothing Then
MsgBox "Leider nichts gefunden"
Else

Tabelle1.Range("F1").Value = Tabelle1.Cells(Ergebnis.Row, 2).Value
End If

End Sub

Ich hoffe es kan mir jemand dabei weiterhelfen

Danke

claudia

[atilla]

Hallo Claudia,

in diesem Fall musst Du die FindNext Methode nutzen. Ist in der Excel Hilfe knapp beschrieben.

So sollte es gehen:

Code:

Option Explicit

Sub ZeileFinden()
   Dim i As Long
   Dim Ergebnis As Range
   Dim strgAddress As String


   With Tabelle1.Columns(1)
      .Columns(6).ClearContents  'Spalte F wird zuerst geleert
      Set Ergebnis = .Find(what:=Tabelle1.Range("E1").Value, _
                   lookat:=xlWhole)
      If Not Ergebnis Is Nothing Then
         strgAddress = Ergebnis.Address
         Do
            i = i + 1
            Tabelle1.Range("F" & i).Value = Tabelle1.Cells(Ergebnis.Row, 2).Value
            Set Ergebnis = .FindNext(Ergebnis)
         Loop While Not Ergebnis Is Nothing And Ergebnis.Address <> strgAddress
      Else
         MsgBox "Leider nichts gefunden"
      End If
   End With
  
End Sub

Bei größeren Datenbeständen eignet sich der Spezialfilter besser.

[claudia]

Perfekt Dankeeeeeee :23:

[Max]

Hallo Claudia,

probier es mal so:

Code:

Sub Suche()
Dim i As Long
Dim ZeileMax As Long
Dim Treffer As Range
Dim strBegriff As String
  
With Tabelle1
strBegriff = .Range("E1").Value
Set Treffer = .Range("A2")
.Columns(6).ClearContents
      
ZeileMax = .Cells(Rows.Count, 6).End(xlUp).Row
      
For i = 1 To WorksheetFunction.CountIf(Columns(1), strBegriff)
  
    Set Treffer = Columns(1).Find(What:=strBegriff, After:=Treffer, _
                LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
                SearchDirection:=xlNext, MatchCase:=False)

    If Not Treffer Is Nothing Then
        Treffer.Offset(0, 1).Copy Destination:=Range("F" & ZeileMax)
        ZeileMax = ZeileMax + 1
    End If
          
Next i
End With

End Sub

Gruß
Max