Re: Remove Duplicates By Id's
Hello there!
Before I begin I just want to say that my code probably isnt the best one, but since I felt I needed some practise I sat down and wrote some code for this.
I did the assumption that one ID can occur more than just twice, so you have more then just two rows to compare (that would have been SOOOO much easier...). I tried my code a few times, and it worked for me on your example + 2 added lines with the ID 19 (as in your example) and codes that are similar to the ones in your example.
Heres the code:
Option Explicit
Sub Compare()
Dim i As Integer
Dim x As Integer
Dim y As Integer
Dim StartRow As Integer
Dim Duplicates As Integer
Dim CurrentCode As String
Dim CurrentCodeStr As String
Dim CodeLn As Integer
Dim PlayCol As Integer
Dim DupCodeFound As Boolean
i = 1
Do While Not Cells(i, 1).Value = Empty
If Cells(i, 1).Value = Cells(i + 1, 1).Value Then 'Checking for duplicate ID´s
StartRow = i
Do While Cells(i, 1).Value = Cells(StartRow, 1).Value 'Collecting all duplicate ID´s
i = i + 1
Loop
i = i - 1
For Duplicates = StartRow To i 'For every duplicate ID we found
CodeLn = Len(Cells(Duplicates, 3).Value) 'We find out how long the Code-string is
CodeLn = (CodeLn + 1) / 3 'and thereby we know how many codes it is
CurrentCodeStr = Cells(Duplicates, 3).Value 'The string for the current code that will be truncated depending on if we find other strings with the same code
For x = 0 To CodeLn - 1 'For every code in the codestring
CurrentCode = Mid(Cells(Duplicates, 3).Value, 1 + (x * 3), 2) 'The code we´re going to check for in the other codestrings
DupCodeFound = False
For y = StartRow + 1 To i
If Not y = Duplicates Then 'We dont want to check the codestring againt itself
If Cells(y, 4).Value = Empty Then 'We want to look at the right column. If we have written anything to Column 4 already, thats the one we´re using for the next check
PlayCol = 3
Else
PlayCol = 4
End If
If InStr(1, Cells(y, PlayCol).Value, CurrentCode) > 0 Then 'If we find the code in another codestring
Cells(y, 4).Value = Mid(Cells(y, PlayCol).Value, 1, (InStr(1, Cells(y, PlayCol).Value, CurrentCode) - 1)) & Mid(Cells(y, PlayCol).Value, (InStr(1, Cells(y, PlayCol).Value, CurrentCode) + 3), Len(Cells(y, PlayCol).Value)) 'We rebuild the string without the found code, and place it in the next column, so we dont overwrite the original
DupCodeFound = True 'A flag so we know we have removed this code from another codestring
End If
End If
Next y
'And finally removing the code from the current one and outputting it in Column 4
If DupCodeFound Then 'ONLY if we already have removed anything from another codestring
Cells(Duplicates, 4).Value = Mid(CurrentCodeStr, 1, (InStr(1, CurrentCodeStr, CurrentCode) - 1)) & Mid(CurrentCodeStr, (InStr(1, CurrentCodeStr, CurrentCode) + 3), Len(CurrentCodeStr))
CurrentCodeStr = Cells(Duplicates, 4).Value 'We change the current codestring thats gonna be output next time we come here
End If
Next x
Next Duplicates
End If
i = i + 1
Loop
End Sub
Display More
As I said, there are most likely better ways of doing this, so you might want to wait until someones else helps you too.
I hope I have commented the code enough to understand the logic in it (its not easy all the time)...
Hope it works for you... 
Kind regards
/Henrik
