Office: Zeilen "extrahieren" mit Makro (Wert suchen,Zellen

Hallo zusammen,

ich brauche ein Makro, das Folgendes kann:

Wenn ich in eine Zelle A 1 in Tabelle 1! einen Wert eingebe,
dann soll dieser Wert in Zeile 1 einer anderen Tabelle (Tabelle2!) gesucht werden.

Wenn dann der Wert in dieser Zeile gefunden wird, dann sollen die ersten drei Zellen dieser Zeile zurück in Tabelle1! in Zeile A2 aufgelistet werden.

Dann soll die Operation in der nächsten Zeile (also Zeile 2) der Tabelle 2! mit demselben Wert wiederholt werden. Wird der Wert wieder gefunden, dann sollen die drei Zellen in Zeile A3 der Tabelle1! aufgelistet werden usw.

Die Suche soll das Makro bis zu Zeile 1500 (in Tabelle2!) ausführen.

Am Ende habe ich dann wohl eine Liste mit allen Trefferzeilen.

Könnte mir jemand den Code posten?

Das wäre sehr nett, vielen Dank!!

LG
Fin

 

Hallo!

Folgendes Makro kopierst Du in ein allgem. Codemodul:

Code:

Sub Tab2_Durchsuchen()
  Dim Zl1 As Long, Zl2 As Long
  Dim WertA1 As Variant, Rg2 As Range, Wsh1 As Worksheet
  
  Set Wsh1 = Worksheets("Tabelle1")
  WertA1 = Wsh1.Range("A1").Value
  Zl1 = 1
  
  With Worksheets("Tabelle2")
    For Zl2 = 1 To 1500
      Set Rg2 = .Rows(Zl2).Find(What:=WertA1, LookIn:=xlValues, lookAt:=xlWhole)
      If Not Rg2 Is Nothing Then
        Zl1 = Zl1 + 1
        .Cells(Zl2, 1).Resize(1, 3).Copy Destination:=Wsh1.Cells(Zl1, 1)
      End If
    Next Zl2
  End With
  
  Application.CutCopyMode = False
  
End Sub

1) In Zelle A1 des Arbeitsblattes 'Tabelle1' den Suchwert eingeben.
2) Die Tastenkombination Alt+F8 drücken, aus der Liste das Makro 'Tab2_Durchsuchen' auswählen, Button 'Ausführen' klicken
3) Ab Zelle A2 im Arbeitsblatt 'Tabelle1' werden die ersten 3 Zellen derjenigen Zeilen des Arbeitsblattes 'Tabelle2' angezeigt, in denen der Wert aus Zelle A1 gefunden wurde.

 

Super, danke, es funktioniert - und hilft mir schon riesig!

Nun habe ich die so lange ersehnte Ergebnisliste, sieht gut aus!

Jetzt eine Anschlussfrage: Kann ich diese Liste wiederum auf ein zweites Suchkriterium durchforsten?

Und die dann entstehende Ergebnisliste auf ein drittes?

Ich habe den Code in ein zweites und drittes Makro einzugeben versucht, nachdem ich ihn etwas angepasst hatte (er soll ja jetzt nicht mehr Tabelle 2, sondern Tabelle 1 durchsuchen und er soll die erste Ergebnisliste vorher löschen.

Aber leider funktioniert außer dem Löschen nichts.

Wie muss der Code aussehen?

Vielen Dank!!!!

 

Hallo!

So ganz schlau bin ich damit leider nicht geworden.
Fürs folgende Makro nehme ich Folgendes an:
1) Es soll das Arbeitsblatt 'Tabelle1' ab Zeile 2 durchsurcht werden (max. 1500 Zeilen)
2) Im Arbeitsblatt 'Tabelle3' wird in Zelle A1 der Suchwert eingegeben.
3) und ab Zeile 2 werden wiederum die ersten 3 Zellen der gefundenen Zeilen aus Arbeitsblatt 'Tabelle1' angezeigt.

Code:

Sub Tab1_Durchsuchen()
  Dim Zl1 As Long, Zl2 As Long
  Dim WertA1 As Variant, Rg2 As Range, Wsh1 As Worksheet
  
  Set Wsh1 = Worksheets("Tabelle3")
  WertA1 = Wsh1.Range("A1").Value
  Zl1 = 1
  
  With Worksheets("Tabelle1")
    For Zl2 = 2 To 1501
      Set Rg2 = .Rows(Zl2).Find(What:=WertA1, LookIn:=xlValues, lookAt:=xlWhole)
      If Not Rg2 Is Nothing Then
        Zl1 = Zl1 + 1
        .Cells(Zl2, 1).Resize(1, 3).Copy Destination:=Wsh1.Cells(Zl1, 1)
      End If
    Next Zl2
  End With
  
  Application.CutCopyMode = False
  
End Sub

 

Klappt alles!!!!

Hi,

das ist gut, danke. Hab es nun ähnlich gemacht: Ich habe "Zwischenblätter" mit Namen SuchKrit1, SuchKrit2 etc. eingefügt, in denen ich die Ergebnisse des vorherigen Suchkriteriums "parke". Beim zweiten Makro (zweites Suchkriterium) lasse ich Excel einfach dort suchen. Vorher aber löscht er die Ergebnisliste (Blatt "Suchmaske") und legt in der erste Zeilen sozusagen einen Suchverlauf mit Suchkriterium 1, 2 etc. an. So überschreibe ich in "A1" immer das vorherige Kriterium, aber in der Suchhistorie sehe ich ja, wonach ich vorher "gefiltert" habe.

Letztlich kann ich so immer das eine Tabellenblatt (Suchmaske) für meine Suche nutzen.

Tausend Dank jedenfalls!!

Viele Grüße
Fin

PS: Für alle Interessierten hier der Code.

1) Suchverlauf löschen
2) Suchkriterium 1 suchen und Liste mit Trefferzeilen zurückgeben (habe diese Liste übrigens auf 500 Zellen erweitert :-))
3) Suchverlauf erstellen in Suchmaske!E1, E2, E3 usw.
4) Ergebnisliste "parken", damit das nächste Suchkriterium dort suchen kann
5) UND WEITER mit Suchkriterium 2, 3 etc.

Sub Suchkriterium1()


'Suchverlauf löschen
'
Range("E1:I1").Select
Selection.ClearContents



'Suche für Suchkriterium 1 durchführen und Liste mit Trefferzeilen zurückgeben

Dim Zl1 As Long, Zl2 As Long
Dim WertA1 As Variant, Rg2 As Range, Wsh1 As Worksheet

Set Wsh1 = Worksheets("Suchmaske")
WertA1 = Wsh1.Range("A1").Value
Zl1 = 1

With Worksheets("ALLESquer")
For Zl2 = 1 To 1500
Set Rg2 = .Rows(Zl2).Find(What:=WertA1, LookIn:=xlValues, lookAt:=xlWhole)
If Not Rg2 Is Nothing Then
Zl1 = Zl1 + 1
.Cells(Zl2, 1).Resize(1, 520).copy Destination:=Wsh1.Cells(Zl1, 1)
End If
Next Zl2
End With

'"Copy-Markierung" aufheben

Application.CutCopyMode = False

'Suchkriterium 1 kopieren und einfügen

Range("A1").Select
Selection.copy
Range("E1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False


' Ergebnisliste in SuchKrit2 einfügen

Application.Goto Reference:="R2C1:R1500C521"
Selection.copy
Sheets("SuchKrit2").Select
Application.Goto Reference:="R1C1"
ActiveSheet.Paste
Range("A1").Select
Sheets("Suchmaske").Select
Range("A1").Select

'"Copy-Markierung" aufheben
'
Application.CutCopyMode = False
End Sub


----

Sub Suchkriterium2()

Sub Suchkriterium2()

' SuchmaskeLoeschen Makro
'
Application.Goto Reference:="R2C1:R1500C521"
ActiveWindow.SmallScroll Down:=-12
Selection.ClearContents

Dim Zl1 As Long, Zl2 As Long
Dim WertA1 As Variant, Rg2 As Range, Wsh1 As Worksheet

Set Wsh1 = Worksheets("Suchmaske")
WertA1 = Wsh1.Range("A1").Value
Zl1 = 1

With Worksheets("SuchKrit2")
For Zl2 = 1 To 1500
Set Rg2 = .Rows(Zl2).Find(What:=WertA1, LookIn:=xlValues, lookAt:=xlWhole)
If Not Rg2 Is Nothing Then
Zl1 = Zl1 + 1
.Cells(Zl2, 1).Resize(1, 500).copy Destination:=Wsh1.Cells(Zl1, 1)
End If
Next Zl2
End With

Application.CutCopyMode = False

'Suchkriterium 2 kopieren und einfügen
Range("A1").Select
Selection.copy
Range("F1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

' Ergebnisliste in SuchKrit3 einfügen

'
Application.Goto Reference:="R2C1:R1500C521"
Selection.copy
Sheets("SuchKrit3").Select
Application.Goto Reference:="R1C1"
ActiveSheet.Paste
Range("A1").Select
Sheets("Suchmaske").Select
Range("A1").Select

' CopyAufheben Makro
'
'
Application.CutCopyMode = False
End Sub




----

Sub Suchkriterium3()

Sub Suchkriterium3()
' SuchmaskeLoeschen Makro
'
Application.Goto Reference:="R2C1:R1500C521"
ActiveWindow.SmallScroll Down:=-12
Selection.ClearContents

Dim Zl1 As Long, Zl2 As Long
Dim WertA1 As Variant, Rg2 As Range, Wsh1 As Worksheet

Set Wsh1 = Worksheets("Suchmaske")
WertA1 = Wsh1.Range("A1").Value
Zl1 = 1

With Worksheets("SuchKrit3")
For Zl2 = 1 To 1500
Set Rg2 = .Rows(Zl2).Find(What:=WertA1, LookIn:=xlValues, lookAt:=xlWhole)
If Not Rg2 Is Nothing Then
Zl1 = Zl1 + 1
.Cells(Zl2, 1).Resize(1, 500).copy Destination:=Wsh1.Cells(Zl1, 1)
End If
Next Zl2
End With

Application.CutCopyMode = False

'Suchkriterium 3 kopieren und einfügen in G1
Range("A1").Select
Selection.copy
Range("G1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select

' Ergebnisliste in SuchKrit4 einfügen

'
Application.Goto Reference:="R2C1:R1500C521"
Selection.copy
Sheets("SuchKrit4").Select
Application.Goto Reference:="R1C1"
ActiveSheet.Paste
Range("A1").Select
Sheets("Suchmaske").Select
Range("A1").Select

' CopyAufheben Makro
'
Application.CutCopyMode = False
End Sub

 

Hallo allerseits,

ich habe noch ne Zusatzfrage: Ich möchte nicht in kompletten Zeilen des Arbeitsblattes suchen, sondern nur in einem Bereich (nämlich in N2:AP1499).

Wie muss ich das obige Makro ändern?

Vielen Dank und viele Grüße
Fin

 

Hallo!

Ich nehme an, Deine Anfrage bezog sich in erster Linie aub die SUB SUCHKRITERIUM1(). Der entsprechende Abschnitt sollte dann in etwa so lauten:

Code:

  'Suche für Suchkriterium 1 durchführen und Liste mit Trefferzeilen zurückgeben
  'N2:AP1499 -> N=14 bzw. AP=42 -> 42-14=28
  
  Dim Zl1 As Long, Zl2 As Long
  Dim WertA1 As Variant, Rg2 As Range, Wsh1 As Worksheet
  
  Set Wsh1 = Worksheets("Suchmaske")
  WertA1 = Wsh1.Range("A1").Value
  Zl1 = 1
  
  With Worksheets("ALLESquer")
    For Zl2 = 2 To 1499
      Set Rg2 = .Cells(Zl2, 14).Resize(1, 29).Find(What:=WertA1, LookIn:=xlValues, lookAt:=xlWhole)
      If Not Rg2 Is Nothing Then
        Zl1 = Zl1 + 1
        'entweder:
        .Cells(Zl2, 1).Resize(1, 520).Copy Destination:=Wsh1.Cells(Zl1, 1)
        'oder:
        '.Cells(Zl2, 14).Resize(1, 29).Copy Destination:=Wsh1.Cells(Zl1, 1)
      End If
    Next Zl2
  End With

Da ich nicht genau wusste, wie Du es mit der COPY-Methode haben möchtest, habe ich die bisherige Variante stehen lassen (die ab Spalte 1 bis Spalte 520 kopiert). Als Kommentar habe ich Dir nach "oder:" die Variante programmiert, die die COPY-Methode für die Spalten N bis AP ausführt.

 

Das klappt wunderbar, danke.

Nur verstehe ich nicht, warum Du aus 1:1500 nun 2:1499 gemacht hast. Ich habe es jetzt auf 1:1499 gestellt und es macht jedenfalls alles, was ich will.

LG
Fin

 

Hallo!

weil Du in Deinem Posting geschrieben hast:

 

Ja, richtig, sry! Hatte mich umentschieden und wollte nun auch in Zeile 1 suchen. Hab's aber jetzt kapiert!!

Tausend Dank noch mal!

LG
Fin