vijyat
04-03-2014, 10:32 AM
Hi,
I am trying to modify an existing code that I found on Mr Excel, there are multiple instances of the same code when googled. I am not sure who the original author is so I can respect and thank him/her for the code. The code works great for what it was intended for however, I can't make heads or tail of the code for me to modify it. Hence I would appreciate any help on this. There have been earlier posts related to de-duplication however, none of them that I found compare multiple columns/attributes.
Excel Version : 2013
Problem : The current VBA code searches for any duplicates in ColA only and merges those duplicate entries into a single entry with its attributes in their respective columns. How ever, if I try to modify the code so that it searches for exact matches in Col A and Col B then it should de-duplicate and merge those entries. Need help with this part.
I am attaching 2 sheets : Vba2 & Vba3. The vba 2 file-sheet 1 has raw data and shows exactly what the current code does and it searches for dup's in Col A and merges attributes and the intended result is in sheet 2 of the file.
Now if I modify the file by adding another column(ColB) for it to verify for duplicate matches, it does not take the ColB into account, instead just uses ColA entries. I added a sample data into the sheet1 of Vba3 file and the intended solution is in Sheet 3 of file Vba2.
VB:
Sub combine()
Dim x, y(), s$, i&, j&, k&, n&
x = Sheets("Sheet1").Range("A1").CurrentRegion.Value
ReDim y(1 To UBound(x, 1), 1 To UBound(x, 2))
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 1 To UBound(x)
If .exists(x(i, 1)) Then
k = .Item((x(i, 1)))
For n = 1 To UBound(x, 2)
If IsEmpty(y(k, n)) Then
y(.Item((x(i, 1))), n) = x(i, n)
End If
Next n
Else
j = j + 1
.Item((x(i, 1))) = j
For k = 1 To UBound(x, 2)
y(j, k) = x(i, k)
Next k
End If
Next i
End With
With Sheets("Current Solution")
.UsedRange.ClearContents
.Range("A1").Resize(j, UBound(x, 2)).Value = y()
With .Range("A2").CurrentRegion
.Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlYes
End With
End With
End Sub
Can someone help me modify this please. Also I would appreciate if one can add comments to the code as I would like to understand what it's doing :bug:. I do not understand the Scripting.Dictionary and CompareMode functions. If it's not too much trouble to ask, how would we modify this even further if we were to compare ColA, ColB, and ColC...more than 3 attributes to find the exact match. ?
Thanks & Regards,
Vijyat
I am trying to modify an existing code that I found on Mr Excel, there are multiple instances of the same code when googled. I am not sure who the original author is so I can respect and thank him/her for the code. The code works great for what it was intended for however, I can't make heads or tail of the code for me to modify it. Hence I would appreciate any help on this. There have been earlier posts related to de-duplication however, none of them that I found compare multiple columns/attributes.
Excel Version : 2013
Problem : The current VBA code searches for any duplicates in ColA only and merges those duplicate entries into a single entry with its attributes in their respective columns. How ever, if I try to modify the code so that it searches for exact matches in Col A and Col B then it should de-duplicate and merge those entries. Need help with this part.
I am attaching 2 sheets : Vba2 & Vba3. The vba 2 file-sheet 1 has raw data and shows exactly what the current code does and it searches for dup's in Col A and merges attributes and the intended result is in sheet 2 of the file.
Now if I modify the file by adding another column(ColB) for it to verify for duplicate matches, it does not take the ColB into account, instead just uses ColA entries. I added a sample data into the sheet1 of Vba3 file and the intended solution is in Sheet 3 of file Vba2.
VB:
Sub combine()
Dim x, y(), s$, i&, j&, k&, n&
x = Sheets("Sheet1").Range("A1").CurrentRegion.Value
ReDim y(1 To UBound(x, 1), 1 To UBound(x, 2))
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 1 To UBound(x)
If .exists(x(i, 1)) Then
k = .Item((x(i, 1)))
For n = 1 To UBound(x, 2)
If IsEmpty(y(k, n)) Then
y(.Item((x(i, 1))), n) = x(i, n)
End If
Next n
Else
j = j + 1
.Item((x(i, 1))) = j
For k = 1 To UBound(x, 2)
y(j, k) = x(i, k)
Next k
End If
Next i
End With
With Sheets("Current Solution")
.UsedRange.ClearContents
.Range("A1").Resize(j, UBound(x, 2)).Value = y()
With .Range("A2").CurrentRegion
.Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlYes
End With
End With
End Sub
Can someone help me modify this please. Also I would appreciate if one can add comments to the code as I would like to understand what it's doing :bug:. I do not understand the Scripting.Dictionary and CompareMode functions. If it's not too much trouble to ask, how would we modify this even further if we were to compare ColA, ColB, and ColC...more than 3 attributes to find the exact match. ?
Thanks & Regards,
Vijyat