Microsoft Excel

Herbers Excel/VBA-Archiv

Zelle suchen, mit ausgeben danebende zelle

Betrifft: Zelle suchen, mit ausgeben danebende zelle von: dieter
Geschrieben am: 15.11.2014 17:46:36

Hallo all,
Ich habe in Tabelle1 die Zelle C1 wo ich den Text suchen lasse in der Tabelle sortiert unter A. Die gefundenen werden mir dann auch in Tabelle1 alle ab C3 nach unten aufgelistet von Tabelle sortiert A.
Ich bekomme es aber nicht hin das er mir auch dann was in dem gefundenen mir die Spalte B mit in dem gefundenen zu übergeben ( kopieren ) Das müsste dann in Spalt D stehen.
Ich hoffe konnte mich genügend ausdrücken.
unten mein Code:

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.Address(0, 0) <> "C1" Then Exit Sub

Dim Suchbereich As Range
Dim Suchbegriff As Variant
Dim D As Range
Dim FindAddr As String
Dim lRow As Long
Dim lngLast As Long

Set Suchbereich = Worksheets("sortiert").[a:a]
Suchbegriff = Worksheets("Tabelle1").Range("C1").Text
lngLast = Worksheets("Tabelle1").Cells(Rows.Count, 3).End(xlUp).Row

lRow = 3
Worksheets("Tabelle1").Range("C3:C" & lngLast + 1).Clear
With Suchbereich
    Set D = .Find(Suchbegriff, lookat:=xlPart, MatchCase:=False)
    If Not D Is Nothing Then
        FindAddr = D.Address
        Do
            Worksheets("Tabelle1").Range("C" & lRow) = D
            lRow = lRow + 1
            Set D = .FindNext(D)
        Loop While Not D Is Nothing And D.Address <> FindAddr
    End If
End With
lngLast = Worksheets("Tabelle1").Cells(Rows.Count, 3).End(xlUp).Row
Worksheets("Tabelle1").Range("C2").Value = lngLast - 2 & " Treffer gefunden"
End Sub

Ich danke schon mal im voraus der Hilfe

Mfg.
dieter

  

Betrifft: AW: Zelle suchen, mit ausgeben danebende zelle von: Tino
Geschrieben am: 15.11.2014 17:53:01

Hallo,
versuch es mal einfach so.

'...
Worksheets("Tabelle1").Range("C" & lRow).Resize(, 2).Value = D.Resize(, 2).Value
'...

Gruß Tino


  

Betrifft: AW: Zelle suchen, mit ausgeben danebende zelle von: dieter
Geschrieben am: 15.11.2014 19:10:06

Hallo Tino,
das ist ja super, klappt super, nur wenn ich was neues suche löscht er nicht alles.
Heißt, vorher 200 gefunden, bei neu suchen 50 gefunden die angezeigt werden aber der Rest bis 200 steht auch noch. Er löscht nicht alles. Denke mal liegt an der Anweisung ?

Worksheets("Tabelle1").Range("C3:C" & lngLast + 1).Clear

Mfg.
dieter


  

Betrifft: willst mich doch auf den Arm nehmen? von: Tino
Geschrieben am: 16.11.2014 16:28:34

Hallo,
für was könnte wohl C3:C stehen?

Gruß Tino


  

Betrifft: AW: willst mich doch auf den Arm nehmen? von: dieter
Geschrieben am: 17.11.2014 14:45:51

Hallo Tino,
Sorry, war mein Fehler. Klappt wunderbar. Danke dafür. Aber für den Arm bist du mir zu schwer. lolol
Letzte Frage, ging das auch als DoubleClick auf die Zelle C1 oder A3:A15 ??
Bin soweit:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("A3:A15")) Is Nothing Then Exit Sub

?????????

Aber wenn ich dann den Rest einfüge klappt es nicht.
Ist nur Frage, ansonsten super das andere.
Mfg.
dieter


  

Betrifft: AW: willst mich doch auf den Arm nehmen? von: Tino
Geschrieben am: 17.11.2014 16:59:56

Hallo,
versuch es so

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim Suchbereich As Range
Dim Suchbegriff As Variant
Dim D As Range
Dim FindAddr As String
Dim lRow As Long
Dim lngLast As Long

If Intersect(Target, Range("A3:A15,C1")) Is Nothing Then Exit Sub
Cancel = True

Suchbegriff = Target.Text
'...
'...
'rest des Codes

End Sub
Gruß Tino


  

Betrifft: AW: willst mich doch auf den Arm nehmen? von: dieter
Geschrieben am: 17.11.2014 18:20:48

Hallo Tino,
Leider Funkt das nur auf Zelle C1. Die Zellen A3 - A15 gehen nicht.
Hier mal so wie du beschrieben hast der ganze Code.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim Suchbereich As Range
Dim Suchbegriff As Variant
Dim D As Range
Dim FindAddr As String
Dim lRow As Long
Dim lngLast As Long

If Intersect(Target, Range("A3:A15,C1")) Is Nothing Then Exit Sub
Cancel = True

Suchbegriff = Target.Text
'...
'...
'rest des Codes

Set Suchbereich = Worksheets("sortiert").[a:a]
Suchbegriff = Worksheets("Tabelle1").Range("C1").Text
lngLast = Worksheets("Tabelle1").Cells(Rows.Count, 3).End(xlUp).Row

lRow = 3
Worksheets("Tabelle1").Range("C3:C" & lngLast + 1).Clear
With Suchbereich
    Set D = .Find(Suchbegriff, lookat:=xlPart, MatchCase:=False)
    If Not D Is Nothing Then
        FindAddr = D.Address
        Do
        Worksheets("Tabelle1").Range("C" & lRow).Resize(, 2).Value = D.Resize(, 2).Value
            lRow = lRow + 1
            Set D = .FindNext(D)
        Loop While Not D Is Nothing And D.Address <> FindAddr
    End If
End With
lngLast = Worksheets("Tabelle1").Cells(Rows.Count, 3).End(xlUp).Row
Worksheets("Tabelle1").Range("C2").Value = lngLast - 2 & " Treffer gefunden"

End Sub
Ich versuche noch was, ob ich Fehler finde sonst lasse ich es so wie es geht.
das würde mir ausreichen. andere wäre ja noch besser aber ich bin auch zufrieden mit einem Finger.

Wie gesagt, super Arbeit von Dir.

Mfg.
dieter


  

Betrifft: versuch es so.... von: Tino
Geschrieben am: 17.11.2014 19:14:04

Hallo,
du überschreibst die Variable Suchbegriff in der Zeile

Suchbegriff = Worksheets("Tabelle1").Range("C1").Text
wieder, dann kann Target nicht gefunden Werten!
Habe auch deine Find Zeile erweitert, damit in Werte gesucht wird und nicht in Formel.
Evtl. ist auch Target.Text (c´vielleicht Target.Value) falsch,
damit suchts du nach den Angezeigten Werte und nach Text nicht nach den waren Zellwert.

Versuch mal so.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim Suchbereich As Range
Dim Suchbegriff As Variant
Dim D As Range
Dim FindAddr As String
Dim lRow As Long
Dim lngLast As Long

If Intersect(Target, Range("A3:A15,C1")) Is Nothing Then Exit Sub
Cancel = True

Suchbegriff = Target.Text
'...
'...
'rest des Codes

With Worksheets("Tabelle1")
    Set Suchbereich = Worksheets("sortiert").[a:a]
    lngLast = .Cells(Rows.Count, 3).End(xlUp).Row
    
    lRow = 3
    .Range("C3:D" & lngLast + 1).Clear
    With Suchbereich
        'in Werte suchen = LookIn:=xlValues
        'in Formel suchen = LookIn:=xlFormulas
        Set D = .Find(What:=Suchbegriff, LookAt:=xlPart, LookIn:=xlFormulas, _
                 SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
        If Not D Is Nothing Then
            FindAddr = D.Address
            Do
                .Range("C" & lRow).Resize(, 2).Value = D.Resize(, 2).Value
                lRow = lRow + 1
                Set D = .FindNext(D)
            Loop While Not D Is Nothing And D.Address <> FindAddr
        End If
    End With
    lngLast = .Cells(Rows.Count, 3).End(xlUp).Row
    .Range("C2").Value = lngLast - 2 & " Treffer gefunden"
End With
End Sub

Gruß Tino


  

Betrifft: AW: versuch es so.... von: dieter
Geschrieben am: 18.11.2014 17:48:35

Hallo Tino,
Wieder mal herzlichen dank für Deine Mühe und Arbeit. Sorry das war mein Fehler das es nicht gefunzt hat da ich vergessen habe die Zeile zu Löschen. Suchbegriff = Worksheets("Tabelle1").Range("C1").Text
Irgendwann sieht man nichts mehr vor lauter fummelei.
So ist jetzt der Code wie er wunderbar geht: allerdings unten erklärt

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim Suchbereich As Range
Dim Suchbegriff As Variant
Dim D As Range
Dim FindAddr As String
Dim lRow As Long
Dim lngLast As Long

If Intersect(Target, Range("A3:A15,C1")) Is Nothing Then Exit Sub
Cancel = True

Suchbegriff = Target.Text   ' .Value egal geht beides

Set Suchbereich = Worksheets("sortiert").[a:a]
' rausgenommen  Suchbegriff = Worksheets("Tabelle1").Range("C1").Text
lngLast = Worksheets("Tabelle1").Cells(Rows.Count, 3).End(xlUp).Row

lRow = 3
Worksheets("Tabelle1").Range("C3:D" & lngLast + 1).Clear
With Suchbereich
      Set D = .Find(What:=Suchbegriff, LookAt:=xlPart, LookIn:=xlFormulas, _
                 SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
' geht mit .find oben oder unten
    ' Set D = .Find(Suchbegriff, LookAt:=xlPart, MatchCase:=False)
    If Not D Is Nothing Then
        FindAddr = D.Address
        Do
        Worksheets("Tabelle1").Range("C" & lRow).Resize(, 2).Value = D.Resize(, 2).Value
            lRow = lRow + 1
            Set D = .FindNext(D)
        Loop While Not D Is Nothing And D.Address <> FindAddr
    End If
End With
lngLast = Worksheets("Tabelle1").Cells(Rows.Count, 3).End(xlUp).Row
Worksheets("Tabelle1").Range("C2").Value = lngLast - 2 & " Treffer gefunden"

End Sub
Aber ich denke ich nehme den Code ohne DoubleClick da er mir nicht so das Ergebnis bringt wie ich brauche.
Und zwar wegen : Ich habe in Spalte A die Namen (mehrfach), Vornamen stehen. In Spalte B die Kundennr.
Jetzt gibt es Z.B Müller.A Müller,B und Mueller,G und Mueller.H, oder Becker und Bäcker mehrfach mit unterschiedlichen Kundennr. Jetzt weiß ich mal grade nicht welchen Bäcker ich suche oder ob als Trennzeichen (.) o. (,) gemacht habe sondern nur den Vornamen wonach ich dann suchen will und da versagt der Code mit DoubleClick. Dein Code Wie gesagt funkt nur soweit super wenn ich genauso habe in meiner Liste.
Hoffe habe mich soweit klarer ausgedrückt.
Nochmal danke für Deine Zeit,Mühe und Arbeit
Du Bist immer weiter zu empfehlen.
Mfg.
Dieter


 

Beiträge aus den Excel-Beispielen zum Thema "Zelle suchen, mit ausgeben danebende zelle"