Combine and Merge Values

[dabigmonky]

Hello,

I was wondering if someone can help me with this logic.

I want a macro which looks for all the duplicate values in column A and and combine the values from column B with a semi colon.

It would look like this:

 

[dabigmonky]

Again, here is the original file:

I would like the macro to create the following result:

Any help would be greatly appreciated. Thanks!

 

[RickXL]

Hi,

This should work:

Sub Transpose()
    Dim ws1  As Worksheet
    Dim ws2  As Worksheet
    Dim dic  As Object
    Dim arr  As Variant
    Dim i    As Long
    Dim Key  As String

    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = ThisWorkbook.Worksheets("Sheet2")
    Set dic = CreateObject("Scripting.Dictionary")
    
    arr = ws1.Range("A2:B" & ws1.Cells(Rows.Count, "A").End(xlUp).Row)
    For i = 1 To UBound(arr)
        Key = arr(i, 1)
        If dic.Exists(Key) Then
            dic(Key) = dic(Key) & "; " & arr(i, 2)
        Else
            dic(Key) = arr(i, 2)
        End If
    Next

    With ws2
        .Range("A1:B1") = Array("Address", "Names")
        .Range("A2").Resize(dic.Count) = Application.Transpose(dic.Keys)
        .Range("B2").Resize(dic.Count) = Application.Transpose(dic.Items)
    End With
End Sub

Note: Application.Transpose will only transpose one row of data. That should be OK for 16,384 records with Excel 2013. We will need to do it another way if you have more data than that.

\the code creates a Dictionary that stores each key value. If a key is new then the new dictionary item is added. If it already exists than the previous list has the new name appended to it.

Tip: The default search options here will find posts with no replies. If you reply to your own post many people will not see them because of that.

 

[dabigmonky]

Thank you for your reply. I tried your code and received error: Run-Time error 13; Type Mismatch

My excel actually has 36,000 rows of data.

 

[RickXL]

OK, if you have more rows than Transpose can cope with then we will need to turn the data round another way.

The code below creates a second array (arr2) and copies the values from the Dictionary into it transposing them in the process.
I have added a Clear statement as well. If you have that many rows you will not notice if one is left over from any previous run.

Sub Transpose()
    Dim ws1   As Worksheet
    Dim ws2   As Worksheet
    Dim dic   As Object
    Dim arr1  As Variant
    Dim arr2  As Variant
    Dim i     As Long
    Dim Key   As String

    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = ThisWorkbook.Worksheets("Sheet2")
    Set dic = CreateObject("Scripting.Dictionary")
    
    arr1 = ws1.Range("A2:B" & ws1.Cells(Rows.Count, "A").End(xlUp).Row)
    For i = 1 To UBound(arr1)
        Key = arr1(i, 1)
        If dic.Exists(Key) Then
            dic(Key) = dic(Key) & "; " & arr1(i, 2)
        Else
            dic(Key) = arr1(i, 2)
        End If
    Next
    
    ReDim arr2(1 To dic.Count, 1 To 2)
    For i = 1 To dic.Count
        arr2(i, 1) = dic.keys()(i - 1)
        arr2(i, 2) = dic.items()(i - 1)
    Next

    With ws2
        .Cells.Clear
        .Range("A1:B1") = Array("Address", "Names")
        .Range("A2").Resize(dic.Count, 2) = arr2
    End With
End Sub

 

[WarPigl3t]

I haven't been on the forumns in a while and got your PM requesting my assistance on this forum. Its been 15 days since you left me the message and I see a viable solution still alludes you. Maybe this will work. Its untested code. If it doesn't then message me again. I don't follow forum threads.

Sub myMacro()
     firstRow = 2
     lastRow = Range("A" & Rows.Count).End(xlUp).Row
     r1 = firstRow
     Do Until r1 > lastRow
          myValue1 = Range("A" & r1).Value
          r2 = r1 + 1
          Do Until r2 > lastRow
               myValue2 = Range("A" & r2).Value
               If myValue1 = myValue2 Then
                    Range("B" & r1).Value = Range("B" & r1).Value & "; " & Range("B" & r2).Value
                    Rows(r2).Delete
                    lastRow = lastRow - 1
               End If
               r2 = r2 + 1
          Loop
          r1 = r1 + 1
     Loop
End Sub

 

[Peter_SSs]

.. got your PM requesting my assistance on this forum. ... Maybe this will work. ... If it doesn't then message me again.

No, dabigmonky don't do that, and WarPigl3t don't ask for it to be done. Refer #4 of the Forum Rules.

 

[Peter_SSs]

@dabigmonky

If your data is sorted by address as it appears to be, you could also try this code.
Currently, it takes data in columns A:B of the active sheet & writes the results to columns D:E. If you do actually want the original data over-written as your images seem to indicate, post back and a small alteration to the code can achieve that.

Sub Rearrange()
  Dim a As Variant, b As Variant
  Dim i As Long, k As Long
  Dim s As String, adr As String
  
  a = Range("A1", Range("B" & Rows.Count).End(xlUp).Offset(1)).Value
  ReDim b(1 To UBound(a), 1 To 2)
  adr = a(1, 1): s = a(1, 2)
  For i = 2 To UBound(a)
    If a(i, 1) = adr Then
      s = s & "; " & a(i, 2)
    Else
      k = k + 1
      b(k, 1) = adr: b(k, 2) = s
      adr = a(i, 1): s = a(i, 2)
    End If
  Next i
  With Range("D1").Resize(k, 2)
    .Value = b
    .Columns.AutoFit
  End With
End Sub