Code abänderung - Dublikate
09.12.2014 14:18:10
Artanan
der User "Rudi Maintaire" war so nett und hat mir einen code geschrieben.
Dieser fasst in meiner Tabelle auf besondere Art Dublikate zusammen.
Dabei wird geprüft, ob in Spalte A gleiche Seriennummern vorhanden sind und falls ja, werden die dahinter liegenden Spalten (falls nicht identisch) in einer Mehrzeiler-Zelle zusammengefasst.
Leider durchschaue ich den Code nicht so ganz und hätte aber noch eine kleine Abänderung.
Es soll nämlich geprüft werden ob die seriennummer in spalte A und das Datum in Spalte B und C identisch ist. Also Kriterium soll nicht nur "gleiche Seriennummer" sein, sondern "gleiche seriennummer, gleiches eingangsdatum und geliches ausgangsdatum" (also die ersten 3 Spalten gleich). Dann erst soll das ganze als Dublikat gelten und die restlichen Spalten werden nach bisherigem Prinzip zusammengefasst.
Ich habe mal eine Beispieldatei angehängt und den Code von Rudi. (Das ganze soll im gleichen Tabellenblatt ablaufen und nicht wie im Beispiel in ein Vorher und ein Nachher blatt getrennt werden)
Wäre cool, wenn einer eine Idee hat.
vielen Dank!
Sub aaaa()
Dim objDic(1 To 8) As Object, oDicA, oDicB, arrIn, arrOut(), i As Long, j As Long
For i = 1 To 8
Set objDic(i) = CreateObject("scripting.dictionary")
Next
arrIn = ActiveSheet.Cells(1, 1).CurrentRegion
For i = 1 To UBound(arrIn)
objDic(1)(arrIn(i, 1)) = 0
For j = 2 To UBound(arrIn, 2)
objDic(j)(arrIn(i, 1) & "|" & arrIn(i, j)) = arrIn(i, j)
Next
Next
ReDim arrOut(1 To objDic(1).Count, 1 To 8)
i = 0
For Each oDicA In objDic(1)
i = i + 1
arrOut(i, 1) = oDicA
For j = 2 To 8
For Each oDicB In objDic(j)
If Split(oDicB, "|")(0) = oDicA Then
If arrOut(i, j) = "" Then
arrOut(i, j) = objDic(j)(oDicB)
Else
arrOut(i, j) = arrOut(i, j) & vbLf & objDic(j)(oDicB)
End If
End If
Next oDicB
Next j
Next oDicA
With ActiveSheet
.Cells.ClearContents
.Cells(1, 1).Resize(UBound(arrOut), UBound(arrOut, 2)) = arrOut
End With
End Sub
https://www.herber.de/bbs/user/94308.xlsm