Merging Duplicate in Column A

[parscon]

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]

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]

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]

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]

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

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

Robert