CODEWITHSUNDEEP
excelvba
user3808977
user3808977

Reputation: 3

concatenate cells when there are duplicates without using Transpose

I am using the following code - thanks @bonCodigo

Sub groupConcat()
Dim dc As Object
Dim inputArray As Variant
Dim i As Integer

    Set dc = CreateObject("Scripting.Dictionary")
    inputArray = WorksheetFunction.Transpose(Sheets(1).Range("A2:B7").Value)

       '-- assuming you only have two columns - otherwise you need two loops
       For i = LBound(inputArray, 2) To UBound(inputArray, 2)
            If Not dc.Exists(inputArray(1, i)) Then
                dc.Add inputArray(1, i), inputArray(2, i)
            Else
                dc.Item(inputArray(1, i)) = dc.Item(inputArray(1, i)) _
                & "; " & inputArray(2, i)
            End If
       Next i

    '--output into sheet
    Sheets(1).Range("D2").Resize(UBound(dc.keys) + 1) = _
              Application.Transpose(dc.keys)
    Sheets(1).Range("E2").Resize(UBound(dc.items) + 1) = _
              Application.Transpose(dc.items)

    Set dc = Nothing
End Sub

A very elegant solution. Unfortunately, I am running into the limitation of using Transpose method. I have long strings that I would like to concatenate using the above code. Any help will be appreciated.

Regards

Upvotes: 0

Views: 132

Answers (2)

IAmDranged
IAmDranged

Reputation: 3020

Sub groupConcat()
    Dim r As Range
    Dim ro As Range
    Dim myr As Range
    Dim vcompt As Integer

    vcompt = 0

    Set ro = Range(Range("A2"), Range("A2").End(xlDown))

    For i = Range("A2").Row To Range("A2").End(xlDown).Row
        Debug.Print Range("A" & i).Address
        Set myr = ro.Find(what:=Range("A" & i).Value, after:=Range("A2").End(xlDown), Lookat:=xlWhole, SearchDirection:=xlNext)

        If myr Is Nothing Or myr.Address = Range("A" & i).Address Then

            mystr = Range("A" & i).Offset(0, 1).Value
            Set r = Range(Range("A" & i), Range("A2").End(xlDown))

            Set myr = r.Find(what:=Range("A" & i).Value, Lookat:=xlWhole, SearchDirection:=xlNext)
            If Not myr Is Nothing And r.Address <> Range("A2").End(xlDown).Address Then
                Do While myr.Address <> Range("A" & i).Address
                    Debug.Print "r: " & r.Address
                    Debug.Print "myr: " & myr.Address
                    mystr = mystr & "; " & myr.Offset(0, 1).Value
                    Set myr = r.FindNext(myr)
                Loop
            End If

            Range("D" & 2 + vcompt).Value = Range("A" & i).Value
            Range("D" & 2 + vcompt).Offset(0, 1).Value = mystr
            vcompt = vcompt + 1

        End If

    Next i

End Sub

Upvotes: 0

brettdj
brettdj

Reputation: 55682

This also uses a variant array but without the `Transpose`. It will ignore blank values to boot.

It runs by column, then by row

Sub Bagshaw()
Dim allPosts As Variant
Dim allPosts2 As Variant
Dim lngRow As Long
Dim lngCol As Long
Dim lngCnt As Long
Dim objDic As Object

Set objDic = CreateObject("Scripting.Dictionary")
allPosts = Range("A2:B5000").Value2
ReDim allPosts2(1 To UBound(allPosts, 1) * UBound(allPosts, 2), 1 To 1)

 For lngCol = 1 To UBound(allPosts, 2)
    For lngRow = 1 To UBound(allPosts, 1)
        If Not objDic.exists(allPosts(lngRow, lngCol)) Then
            If Len(allPosts(lngRow, lngCol)) > 0 Then
                objDic.Add allPosts(lngRow, lngCol), 1
                lngCnt = lngCnt + 1
                allPosts2(lngCnt, 1) = allPosts(lngRow, lngCol)
             End If
        End If
    Next
Next
Range("D2").Resize(UBound(allPosts2, 1)).Value2 = allPosts2
End Sub

Upvotes: 1

Related Questions