Doppelte Werte suchen und die dan in die neue Tabelle automatisch einfügen

[ECM25]

Hallo Leute, :15:

Ich möchte gern einen Ausgegebenen Wert noch einmal in der Tabelle nach einen gleichen oder +-10 durchsuchen und diese dann in einer extra Tabelle automatisch einfügen.
Wie geht so etwas?

Vielen Dank für jede Hilfe !!!

[ECM25]

Gibt es keinen, der mir da helfen kann?

[Steffl]

Hallo,

in meinen Vorschlag wird bisher der Wert nur einmal gefunden. Sollte er ein zweites Mal auftauchen muss er dann auch aufgelistet werden?

Code:

Sub prcX()
   Dim rngSuche As Range
   Dim lngLastRow As Long, lngC As Long
   Dim strArt As String
  
   With Worksheets("Tabelle1")
      For lngC = -10 To 10
         Set rngSuche = .Range("E5:N16").Find(what:=.Range("P11") + lngC, LookIn:=xlValues, lookat:=xlWhole)
         If Not rngSuche Is Nothing Then
            lngLastRow = .Cells(.Rows.Count, 20).End(xlUp).Row + 1
            .Cells(lngLastRow, 20).Value = rngSuche.Value
            .Cells(lngLastRow, 21).Value = IIf(rngSuche.Column < 10, "X", "Y")
            .Cells(lngLastRow, 22).Value = .Cells(4, rngSuche.Column).Value
            .Cells(lngLastRow, 23).Value = "Option" & IIf(rngSuche.Row < 10, "1", "2")
            Select Case rngSuche.Row
               Case 5 To 7, 11 To 13
                  strArt = "Art1"
               Case Else
                  strArt = "Art2"
            End Select
            .Cells(lngLastRow, 24).Value = strArt
            .Cells(lngLastRow, 25).Value = .Cells(rngSuche.Row, 4).Value
         End If
      Next lngC
   End With

End Sub

Nachtrag: Jetzt wird jeder Treffer aufgelistet.

Code:

Sub prcX2()
   Dim rngSuche As Range
   Dim lngLastRow As Long, lngC As Long
   Dim strArt As String, strAdresse As String
  
   With Worksheets("Tabelle1")
      For lngC = -10 To 10
         Set rngSuche = .Range("E5:N16").Find(what:=.Range("P11") + lngC, LookIn:=xlValues, lookat:=xlWhole)
         If Not rngSuche Is Nothing Then
            strAdresse = rngSuche.Address
            Do
               lngLastRow = .Cells(.Rows.Count, 20).End(xlUp).Row + 1
               .Cells(lngLastRow, 20).Value = rngSuche.Value
               .Cells(lngLastRow, 21).Value = IIf(rngSuche.Column < 10, "X", "Y")
               .Cells(lngLastRow, 22).Value = .Cells(4, rngSuche.Column).Value
               .Cells(lngLastRow, 23).Value = "Option" & IIf(rngSuche.Row < 10, "1", "2")
               Select Case rngSuche.Row
                  Case 5 To 7, 11 To 13
                     strArt = "Art1"
                  Case Else
                     strArt = "Art2"
               End Select
               .Cells(lngLastRow, 24).Value = strArt
               .Cells(lngLastRow, 25).Value = .Cells(rngSuche.Row, 4).Value
               Set rngSuche = .Range("E5:N16").FindNext(rngSuche)
            Loop While rngSuche.Address <> strAdresse
         End If
      Next lngC
   End With

End Sub

[ECM25]

Hi :)

Vielen Dank für deine Hilfe.
Und ja, falls der Wert mehrmals in der gesuchten Tabelle auftaucht, so sollen alle in die andere Tabelle aufgelistet werden.
Ich bin leider kein Excel Experte, soweit ich sehen kann, arbeitest du da an einem Makro?

Gibt es andere Möglichkeiten?
Ich meine, ohne ein Makro zu benutzen?

[Steffl]

Hallo,

ja, das was ich gepostet habe ist ein Makro. Wie und wo Du das Makro einfügen mußt, wird dir hier gezeigt.

Ob es hier eine Lösungsmöglichkeit mit einer Formel gibt? Ich habe keine Ahnung.

[ECM25]

Hmmm :s

Muss jetzt also VBA lernen

Danke!!!
Ich habe nun den Makro drin.
Jetzt ist die Frage wie das ganze Funktioniert? Hast du zufällig eine Liste was einzelne Befehle Bedeuten?

Es gibt leider noch ein Problem mit der erneuten Auswahl.
Bei neuem Wert in Zelle "P11" werden die alten Werte aus der Tabelle nicht überschrieben, Sie werden einfach in die nächsten Zeilen darunter eingefügt.
Kann man das nicht ändern?
Bei neuer Auswahl sollen neue Werte die alten ersetzen.
L.G.

[Steffl]

Hallo,

ich habe die Löschzeile in das Makro eingefügt und das Makro selber ein wenig kommentiert. Ich hoffe, es reicht dir.

Code:

Sub prcX2()
   Dim rngSuche As Range
   Dim lngLastRow As Long, lngC As Long
   Dim strArt As String, strAdresse As String
  
   With Worksheets("Tabelle1")
      'die Daten aus dem Auswertebereich löschen
      .Cells(18, 20).Resize(.Cells(17, 20).End(xlDown).Row - 17, 6).ClearContents
      'Schleife für den Suchwert und -/+ 10
      For lngC = -10 To 10
         'der Wert wird im Zellbereich E5:N16 gesucht
         Set rngSuche = .Range("E5:N16").Find(what:=.Range("P11") + lngC, LookIn:=xlValues, lookat:=xlWhole)
         'wenn es einen Treffer gibt....
         If Not rngSuche Is Nothing Then
            '...wird die Adresse des ersten Treffers in einer Variablen gespeichert....
            strAdresse = rngSuche.Address
            Do
               '... und die erste freie Zelle im Auswertebereich gesucht....
               lngLastRow = .Cells(.Rows.Count, 20).End(xlUp).Row + 1
               ' ... und in die Tabelle eingetragen
               .Cells(lngLastRow, 20).Value = rngSuche.Value
               .Cells(lngLastRow, 21).Value = IIf(rngSuche.Column < 10, "X", "Y")
               .Cells(lngLastRow, 22).Value = .Cells(4, rngSuche.Column).Value
               .Cells(lngLastRow, 23).Value = "Option" & IIf(rngSuche.Row < 11, "1", "2")
               Select Case rngSuche.Row
                  Case 5 To 7, 11 To 13
                     strArt = "Art1"
                  Case Else
                     strArt = "Art2"
               End Select
               .Cells(lngLastRow, 24).Value = strArt
               .Cells(lngLastRow, 25).Value = .Cells(rngSuche.Row, 4).Value
               'Suche nach einen weiteren Treffer
               Set rngSuche = .Range("E5:N16").FindNext(rngSuche)
            'und wiederhole es solange, bis der erste Treffer wieder gefunden wird
            Loop While rngSuche.Address <> strAdresse
         End If
      Next lngC
   End With

End Sub

[ECM25]

Vielen Dank! :23:

Ich muss mich nun mit der VBA Sprache etwas auseinandersetzen.
Darf ich dir eine PN senden, falls da noch Fragen auftauchen?

L.G.

[Steffl]

Hallo,

besser wäre es, Du würdest die Fragen im Forum stellen.

[ECM25]

Hallo :)


Ich habe mich nun mit VBA etwas länger beschäftigt und habe es herausgefunden, wie der Ablauf des Programms ungefähr geht.

Nun habe ich jedoch Fragen bezüglich der Ausgabe der Makros.
Die Makros können ja über eine Schaltfläche ausgegeben werden.

Bsp. Ich habe den gesuchten Wert nicht in Tabelle1 ("P11") sondern in Tabelle2.("P11").
Ich möchte nun mit Hilfe einer Schaltfläche den gesuchten Wert aus Tabelle2 in Tabelle2 ausgeben.
Auf Grund von With Worksheets("Tabelle1") wird der Makro in Tabelle2 nicht ausgeführt.
Wie kann man das ändern?


MFG