PDA

View Full Version : [SOLVED] Merging Duplicate in Column A



parscon
12-27-2013, 09:00 AM
Hello ,
I have the below VBA code that will check column A and if find duplicate data will merge them and my problem it will work from row 2 (A2)
I want to use this vba code from Row 1 that mean A1.
Also i need the item paste on Results from A1
Thank you.



Option Explicit
Sub Merging_Duplicate()

Dim a, i As Long, ii As Long, n As Long, z As String, x As Long
a = Sheets("Sheet1").Range("a1").CurrentRegion.Value
n = 1
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(a, 1)
For ii = 1 To 1
z = z & Chr(2) & a(i, ii)
Next
If Not .exists(z) Then
n = n + 1: .Item(z) = n
For ii = 1 To UBound(a, 2)
a(n, ii) = a(i, ii)
Next
Else
x = .Item(z)
For ii = 2 To UBound(a, 2)
If a(i, ii) <> "" Then
a(x, ii) = a(x, ii) & IIf(a(x, ii) <> "", ", ", "") & a(i, ii)
End If
Next
End If
z = ""
Next
End With
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Results").Delete
On Error Goto 0
Sheets.Add().Name = "Results"
With Sheets("Results").Cells(1).Resize(n, UBound(a, 2))
.Value = a


End With
End Sub

Trebor76
12-27-2013, 05:56 PM
Hi parscon,

Here's how I'd do it:


Option ExplicitSub ListUnique()


Dim rngCell As Range

Application.ScreenUpdating = False


On Error Resume Next
Application.DisplayAlerts = False
Sheets("Results").Delete
Application.DisplayAlerts = True
On Error GoTo 0

Sheets.Add().Name = "Results"

With CreateObject("Scripting.Dictionary")
For Each rngCell In Sheets("Sheet1").Range("A1:A" & Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row)
If Len(rngCell.Value) > 0 Then
If Not .Exists(rngCell.Value) Then
.Add rngCell.Value, rngCell.Value
If .Count = 1 Then
Sheets("Results").Range("A1").Value = rngCell.Value
Else
Sheets("Results").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = rngCell.Value
End If
End If
End If
Next rngCell
End With

Application.ScreenUpdating = True

MsgBox "Unique items are now listed.", vbInformation, "Excel Guru"


End Sub

Regards,

Robert

parscon
12-28-2013, 04:59 AM
Dear Robert,
Thank you but you made different VBA code and the result is different with mine VBA code.
Just i need the same result of the first VBA code but start from First row not second row .
Thank you.

parscon
12-28-2013, 05:11 AM
Just i changed my code to the below code and now it working that i asked.




Option Explicit
Sub Merging_Duplicate()

Dim a, i As Long, ii As Long, n As Long, z As String, x As Long
a = Sheets("Sheet1").Range("a1").CurrentRegion.Value
n = 0
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 1 To UBound(a, 1)
For ii = 1 To 1
z = z & Chr(2) & a(i, ii)
Next
If Not .exists(z) Then
n = n + 1: .Item(z) = n
For ii = 1 To UBound(a, 2)
a(n, ii) = a(i, ii)
Next
Else
x = .Item(z)
For ii = 2 To UBound(a, 2)
If a(i, ii) <> "" Then
a(x, ii) = a(x, ii) & IIf(a(x, ii) <> "", ", ", "") & a(i, ii)
End If
Next
End If
z = ""
Next
End With
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Results").Delete
On Error Goto 0
Sheets.Add().Name = "Results"
With Sheets("Results").Cells(1).Resize(n, UBound(a, 2))
.Value = a


End With
End Sub

Trebor76
12-28-2013, 10:08 PM
Thank you but you made different VBA code and the result is different with mine VBA code.

That's odd as it only listed the unique entries for me :confused:

Anyway as long as it's solved now that's great.

Robert