per VBA doppelte Werte finden

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Test() Dim LR As Integer, i As Integer, Z1 As Integer Z1 = 2 ' ggf wegen Überschrift LR = Cells(Rows.Count, "D").End(xlUp).Row 'letzte Zeile der Spalte For i = Z1 To LR If WorksheetFunction.CountIfs(Columns(4), Cells(i, 4), Columns(6), "> 0") > 1 Then GoTo Ende End If Next MsgBox "Alles OK" Exit Sub Ende: MsgBox Cells(i, 4) & " Mehrfach vorhanden." End Sub

dann probier mal diesen Code


Sub Mehrfach_Kreditkarten()
Dim dic As Object
Dim z As Long
Dim arr
Dim Erg
Dim x As Long
Set dic = CreateObject("Scripting.dictionary")
arr = Cells(1, 1).CurrentRegion
For z = 2 To UBound(arr, 2)
If arr(z, 8) > 0 Then
If dic(arr(z, 4)).exists Then
If InStr(dic(arr(z, 4)), arr(z, 5)) = 0 Then dic(arr(z, 4)) = dic(arr(z, 4)) & ";" & arr(z, 5)
Else
dic(arr(z, 4)) = arr(z, 5)
End If
End If
Next
arr = dic.Keys
ReDim Erg(1 To dic.Count, 1 To 2)
For z = 0 To UBound(arr)
If dic(arr(z)) Like "*;*" Then
x = x + 1
Erg(x, 1) = arr(z)
Erg(x, 2) = dic(arr(z))
End If
Next
Cells(1, Columns.Count).End(xltoleft).Offset(0, 2).Resize(UBound(Erg, 1), UBound(Erg, 2)) = Erg
End Sub

mangels Beispieldatei nicht getestet.
die Ausgabe erfolgt neben den Daten, in der ersten Spalte alle Personalnummern, die mehrere Kreditkarten verwenden und daneben die Kreditkartennummern.
Gruß Daniel

Wie gesagt, ohne deine Datei zu kennen, ist es schwierig, passenden Code zu schreiben.
Du kannst auch deine Daten an den Code anpassen, verschieben die Tabelle einfach so, dass die Tabelle
mit der Überschrift in Zelle A1 beginnt.
Dann sollte der ursprüngliche Code passen (natürlich mit Ubound(Art, 1))
Welchen Zellbereich das .CurrentRegion selektiert, kannst du selber testen in dem du die angegebene Zelle markierst und STRG+A drückst.
Dieser Zellbereich geht dann ins Array. Sollte der Zellbereich für Array nicht in A1 beginnen, müssen Zeilen- und Spaltennummern ggf angepasst werden, da die Zählung im Array immer mit 1 beginnt.
Die Ausgabe des Ergebnisses sollest du dann vielleicht auch besser auf einem anderen Blatt machen.


Sheets("Tabelle2").Cells(1, 1).resize(ubound(Erg, 1), Ubound(erg, 2)) = erg

Gruß Daniel

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

51 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

per VBA doppelte Werte finden

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

51 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread