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

[atilla]

Hallo,

änder doch einfach Tabelle1 in Tabelle2 um.

Wenn Du etwas anderes ereichen möchtest, dann solltest Du erneut eine passende Beispieldatei einstellen.

[ECM25]

Danke für die schnelle Antwort


So hier ist das Beispiel.

Thx !

[atilla]

Hallo,

da hast Du aber einige Änderungen gemacht in der Datei.

Man muss im Code natürlich auch die Bereiche neu Anpassen und nicht nur die Tabellen:

Code:

Sub prcX2()
   Dim rngSuche As Range
   Dim lngLastRow As Long, lngC As Long
   Dim strArt As String, strAdresse As String
  
   With Worksheets("Tabelle2")
      'die Daten aus dem Auswertebereich löschen
      .Cells(15, 7).Resize(.Cells(15, 7).End(xlDown).Row - 14, 6).ClearContents
      'Schleife für den Suchwert und -/+ 10
      For lngC = -10 To 10
         'der Wert wird im Zellbereich E5:N16 gesucht
         Set rngSuche = Worksheets("Tabelle1").Range("E5:N16").Find(What:=.Range("E7") + 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, 7).End(xlUp).Row + 1
               ' ... und in die Tabelle eingetragen
               .Cells(lngLastRow, 7).Value = rngSuche.Value
               .Cells(lngLastRow, 8).Value = IIf(rngSuche.Column < 10, "X", "Y")
               .Cells(lngLastRow, 9).Value = Worksheets("Tabelle1").Cells(4, rngSuche.Column).Value
               .Cells(lngLastRow, 10).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, 11).Value = strArt
               .Cells(lngLastRow, 12).Value = .Cells(rngSuche.Row, 4).Value
               'Suche nach einen weiteren Treffer
               Set rngSuche = Worksheets("Tabelle1").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]

Es Funktioniert!! :19:

Danke!

[ECM25]

Ist es möglich in die Range.Find Methode noch extra Suchkriterien einzubauen?
Ich möchte die Ausgabe noch extra Filtern.


Find(What:=.Range("E7 Or D7") so eine Schreibweise funktioniert leider nicht.

Sub prcX2()
Dim rngSuche As Range
Dim lngLastRow As Long, lngC As Long
Dim strArt As String, strAdresse As String

With Worksheets("Tabelle2")
'die Daten aus dem Auswertebereich löschen
.Cells(15, 7).Resize(.Cells(15, 7).End(xlDown).Row - 14, 6).ClearContents
'Schleife für den Suchwert und -/+ 10
For lngC = -10 To 10
'der Wert wird im Zellbereich E5:N16 gesucht
Set rngSuche = Worksheets("Tabelle1").Range("E5:N16").Find(What:=.Range("E7") + 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, 7).End(xlUp).Row + 1
' ... und in die Tabelle eingetragen
.Cells(lngLastRow, 7).Value = rngSuche.Value
.Cells(lngLastRow, 8).Value = IIf(rngSuche.Column < 10, "X", "Y")
.Cells(lngLastRow, 9).Value = Worksheets("Tabelle1").Cells(4, rngSuche.Column).Value
.Cells(lngLastRow, 10).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, 11).Value = strArt
.Cells(lngLastRow, 12).Value = .Cells(rngSuche.Row, 4).Value
'Suche nach einen weiteren Treffer
Set rngSuche = Worksheets("Tabelle1").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

[Steffl]

Hallo,

was heißt extra filtern? Steht jetzt der Suchwert in E7 oder in D7? Und von was hängt es ab, wo der Suchwert steht?

[ECM25]

So hier das Beispiel :)

[Steffl]

Hallo,

mir scheint, Du hast den Ausgabebereich wieder verändert.

Code:

Sub prcX2()
   Dim rngSuche As Range
   Dim lngLastRow As Long, lngC As Long
   Dim strArt As String, strAdresse As String
  
   With Worksheets("Tabelle2")
      'die Daten aus dem Auswertebereich löschen
      .Cells(2, 7).Resize(.Cells(2, 7).End(xlDown).Row - 1, 6).ClearContents
      'Schleife für den Suchwert und -/+ 10
      For lngC = -10 To 10
         'der Wert wird im Zellbereich E5:N16 gesucht
         Set rngSuche = Worksheets("Tabelle1").Range("E5:N16").Find(What:=.Range("B6") + 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
               If Worksheets("Tabelle1").Cells(4, rngSuche.Column).Value = .Cells(6, 4).Value And _
               (.Cells(6, 3).Value = "X" And rngSuche.Column < 10 Or .Cells(6, 3).Value = "Y" And rngSuche.Column > 9) Then
                  '... und die erste freie Zelle im Auswertebereich gesucht....
                  lngLastRow = .Cells(.Rows.Count, 7).End(xlUp).Row + 1
                  ' ... und in die Tabelle eingetragen
                  .Cells(lngLastRow, 7).Value = rngSuche.Value
                  .Cells(lngLastRow, 8).Value = IIf(rngSuche.Column < 10, "X", "Y")
                  .Cells(lngLastRow, 9).Value = Worksheets("Tabelle1").Cells(4, rngSuche.Column).Value
                  .Cells(lngLastRow, 10).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, 11).Value = strArt
                  .Cells(lngLastRow, 12).Value = .Cells(rngSuche.Row, 4).Value
                  'Suche nach einen weiteren Treffer
               End If
               Set rngSuche = Worksheets("Tabelle1").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]

Super! :)

Gibt es keine Möglichkeit zu bestimmen in welchen Bereich der Tabelle die Ausgabe anfangen Soll?
Wenn ich z.B. möchte, dass die Ausgabe ab einem bestimmten Zeilen und Spalten Abstand beginne soll?

Ich weiß z.B. das mit .Cells(lngLastRow, 7).Value Die Ausgabe ab Spalte 7 beginnt. Jedoch der Zeilen Abstand wird ja automatisch durch die Variable vorgegeben, die oben im Code automatisch mit Zeilen gefüttert wird.

MFG

[Rabe]

Hi,

dann schreibe halt in die Formel rein:

.Cells(lngLastRow + 10, 7).Value

oder schreibe vorher:
lngLastRow = lngLastRow + 10