mehrfach vorkommende Produktnummern

Question

Hallo,

ich habe einen einfachen Code mit dem ich in Spalte A nach mehrfach vorkommenden aufsteigend sortierten Produktnummern suche. Wenn dies der Fall ist werden diese neben der Tabelle aufgelistet:

Sub MultiNr()


Dim rng As Range, iRow As Integer
Z = Cells(Rows.Count, 1).End(xlUp).Row
m = 1
For n = 1 To Z - 1
Set rng = Range(Cells(n + 1, 1), Cells(Z, 1)).Find( _
what:=Cells(n, 1), lookat:=xlWhole, LookIn:=xlValues)
If Not rng Is Nothing Then
iRow = rng.Row
Range(Cells(iRow - 1, 1), Cells(iRow - 1, 4)).Copy
Range(Cells(m, 6), Cells(m, 9)).PasteSpecial
Range(Cells(iRow, 2), Cells(iRow, 4)).Copy
Range(Cells(m, 10), Cells(m, 12)).PasteSpecial
m = m + 1


End If

Next

End Sub
Das klappt soweit einwandfrei, wie diese Produktnummern max. 2 mal vorkommen. Kommen Nr. mehr als 2 mal vor klappt das nicht mehr eindeutig. Das liegt wohl an der Zeile set rng=.... die mir nur anzeigt ob die Nr. noch mal vorkommt aber leider nicht die genaue Positionen/Zeilennummern aller Vorkommen liefert. Weiß jemand wie es besser geht?
Gruß
Andreas

Answer 1

Hallo Andreas,

probier mal folgende Alternative

Option Explicit

Sub mehrfach()
Dim rngC As Range
For Each rngC In Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
If WorksheetFunction.CountIf(Range("A:A"), rngC) > 1 And WorksheetFunction.CountIf(Range("B:B"), rngC) = 0 Then
Range("B" & Cells(Rows.Count, 2).End(xlUp).Row + 1) = rngC
End If
Next
End Sub

Duplikate werden in Spalte B aufgelistet.

Gruß
Rainer

Answer 2

Hallo Rainer,

klappt noch nicht ganz. Die Produktnummern werden am Tabellenende offenbar bei jedem Durchlauf überschrieben, so dass nur eine Nr. sichtbar übrig bleibt. Das Verfahren scheint zu funktionieren, die Darstellung klappt noch nicht.
Hier die Struktur der Testatbelle:

209 Herr Matthias
210 Frau Leon
211 Herr Nico
212 Herr Klaus-Peter
213 Frau Miriam
214 Frau Franziska
215 Herr Sebastian
216 Herr Martin
217 Frau Charlotte
217 Frau Johanna
217 Herr Andreas
218 Frau Elisabeth
219 Herr Max
220 Frau Susanne
220 Frau Sabine
222 Herr Dr. Rainer
223 Herr Linus
224 Herr Leon Gabor
225 Frau Cornelia

Die 217 und 220 müssten entsprechend erkannt und angezeigt/aufgelistet werden.

Ich verstehe auch noch nicht wozu die zusätzliche Bedingung "And WorksheetFunction.CountIf(Range("B:B"), rngC)" dient.
Gruß Andreas

Answer 3

Hallo Andreas,

ich hatte Dich so verstanden, dass die mehrfach vorkommenden Nummern je 1x in der Nebenspalte aufgelistet werden sollen.

Folgender Code listet sie so oft auf wie sie vorliegen (in Spalte D)

Option Explicit

Sub mehrfach()
Dim rngC As Range
For Each rngC In Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
If WorksheetFunction.CountIf(Range("A:A"), rngC) > 1 Then
Range("D" & Cells(Rows.Count, 4).End(xlUp).Row + 1) = rngC
End If
Next
End Sub

Gruß
Rainer

Answer 4

Hallo Rainer,

ich habe deinen Code etwas modifiziert und er liefert mir jetzt das gewünschte Ergebnis. Danke für deinen Tipp!!!

Sub mehrfach()
Dim rngC As Range
m = 1
For Each rngC In Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
If WorksheetFunction.CountIf(Range("A:A"), rngC) > 1 And WorksheetFunction.CountIf(Range("B:B"), rngC) = 0 Then
iRow = rngC.Row
Range(Cells(iRow, 1), Cells(iRow, 4)).Copy
Range(Cells(m, 10), Cells(m, 12)).PasteSpecial
m = m + 1
End If
Next
End Sub

Allerdings bin ich nicht im Klaren darüber was diese zusätzliche Bedingung in deiner Formel
...And WorksheetFunction.CountIf(Range("B:B"), rngC) = 0...
bewirken soll.
Gruß Andreas

Answer 5

...sorry, hatte bei meiner letzten Bemerkung deine vorangegangene Antwort noch nicht gesehen. In jedem Fall vielen Dank für deine Lösung!
A.