Delete duplicate data column A and merge data in colum B into single cell

**GAIMoore** · 02-19-2013, 03:43 PM

I have a set of data (around 700 rows) that contains duplicate values in column A. The data in column B needs to be merged and the duplicates need to be deleted. I have some VBA that I found that finds the duplicates and deletes them, but it does not merge the data in column B so I am losing the data when I run it. I am attaching an example of the data I have, as well as the format it should be similar to after deleting the duplicates.

Option Explicit
Sub CombineColumnsToCommonRowSAS()
Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If Cells(i - 1, 1) = Cells(i, 1) Then
For j = 2 To Cells(i, Columns.Count).End(xlToLeft).Column
 If Cells(i, j) <> "" Then Cells(i - 1, j) = Cells(i, j)
Next j
 Rows(i).Delete
End If
Next i
Application.ScreenUpdating = True
End Sub

**AB33** · 02-19-2013, 03:52 PM

Sub minemerge()
Dim x, i As Long, j As Long, k As Long, n As Long
With Sheets("Sheet1").Range("A1:B" & Cells(Rows.Count, 1).End(xlUp).Row)
    x = .Value
With CreateObject("Scripting.Dictionary")
    .comparemode = 1
    For i = 1 To UBound(x)
        If .exists(x(i, 1)) Then
            n = .Item(x(i, 1))
            x(.Item(x(i, 1)), 2) = x(.Item(x(i, 1)), 2) & " " & x(i, 2)
          
        Else
            j = j + 1
            .Item(x(i, 1)) = j
            For k = 1 To UBound(x, 2)
            x(j, k) = x(i, k)
            Next k
        End If
    Next i

End With
.Offset(.Rows.Count + 2).Resize(j, UBound(x, 2)).Value = x
End With

End Sub

**GAIMoore** · 02-19-2013, 04:17 PM

Thank you. That is exactly what I needed! Very quick response too.

Edit- Both of these responses do exactly what I need, but the top one adds the new data below the original data and the second response overwrites the original data. It is nice to have the option to overwrite or not. Thank you both for the help.

**mike7952** · 02-19-2013, 04:00 PM

This should do it

Option Explicit

Sub abc()
 Dim aArr, e, i As Long
 Dim ws As Worksheet
 
 Set ws = Worksheets("sheet1")
 With ws
    aArr = .Range("a1").CurrentRegion.Value
    .Range("a1", .Cells(Rows.Count, "a").End(xlUp).Offset(1)).EntireRow.Delete
 End With
 
 With CreateObject("scripting.dictionary")
    .comparemode = 1
    For i = 1 To UBound(aArr)
        If Not .exists(aArr(i, 1)) Then
            .Item(aArr(i, 1)) = aArr(i, 2)
        Else
            .Item(aArr(i, 1)) = Join(Array(.Item(aArr(i, 1)), aArr(i, 2)), " ")
        End If
    Next
    i = 2
    For Each e In .keys
        ws.Cells(i, "a") = e
        ws.Cells(i, "b") = .Item(e)
        i = i + 1
    Next
 End With
 
End Sub