Thread: Merge data in a range of cells using a macro

I am at my wits end, literally. Been trying this for 48 hours and just about to give up. Here is the situation:

---

SHEET1

USERID	USERNAME	INCIDENTNUM	PLACENUM_1	PLACENUM_2	PLACENUM_3	PLACENUM_4
A1	RA	blank	blank	A	A	blank
A1	RA	blank	blank	B	blank	A
A1	RA	blank	blank	A	blank	blank
A2	KI	blank	blank	M	blank	blank
A1	RA	blank	C	blank	C	blank

I want to create a function "JustMergeIt" that will accept the following arguments:
1.Search_Column
2.Search_String
3.Merge_Column_Range

So, if I call:
JustMergeit(A;"A1";D:G)
it should return the answer as
"A,B,C"

That is, for every row that has "A1" in the first column of the table, the function has to retrieve what is there in the columns D,E, F and G (called PlaceNum_1..4), and concatenate them WITHOUT repetition, and this has to be done for ALL rows where A1 is there. In other words, it should concatenate all unique values in the four columns (putting some delimiter between the uniquevalues) and return one string to me.

ExelZeus/Athena Help me, please!

Hi Upparna,

I believe you are looking for a "Collection". See http://www.exceltip.com/st/Count_uni...Excel/520.html
If you can attach a sample workbook we can work on what you want.

Upparna,

Give this UDF a try. To use it with the example you provided above, the formula would be:
=JustMergeIt(A:A,"A1",D:G)

Public Function JustMergeIt(Search_Column As Range, Search_String As String, Merge_Column_Range As Range, Optional strDelimiter = ",") As String
    
    Dim rngRow As Range
    Dim rngCell As Range
    Dim rngFound As Range
    Dim bUnq As Boolean
    Dim arrIndex As Long
    Dim arrMax As Long
    Dim strFirst As String
    Dim arrUnq() As String
    ReDim arrUnq(1 To 1000000)
    
    If Search_Column.Columns.Count > 1 Then Exit Function
    
    On Error Resume Next
    With Intersect(ActiveSheet.UsedRange, Search_Column)
        Set rngFound = .Find(Search_String, , xlValues, xlWhole)
        If Not rngFound Is Nothing Then
            strFirst = rngFound.Address
            Do While Not rngFound Is Nothing
                Set rngRow = Intersect(Rows(rngFound.Row), Merge_Column_Range)
                If Not rngRow Is Nothing Then
                    For Each rngCell In rngRow
                        If Trim(rngCell.Text) <> vbNullString Then
                            bUnq = True
                            For arrIndex = 1 To arrMax
                                If rngCell.Text = arrUnq(arrIndex) Then
                                    bUnq = False
                                    Exit For
                                End If
                            Next arrIndex
                            If bUnq = True Then
                                arrMax = arrMax + 1
                                arrUnq(arrMax) = rngCell.Text
                            End If
                        End If
                    Next rngCell
                End If
                Set rngFound = .Find(Search_String, rngFound, xlValues, xlWhole)
                If rngFound.Address = strFirst Then Exit Do
            Loop
        End If
    End With
    
    If arrMax > 0 Then
        ReDim Preserve arrUnq(1 To arrMax)
        JustMergeIt = Join(arrUnq, strDelimiter)
    Else
        JustMergeIt = "No matches"
    End If
    
End Function

Hi,

I find another solution at http://www.cpearson.com/excel/Collec...ctionaries.htm
Look at the section called Range To Collection.

I hope this gives you a better answer. You will need to convert the collection to a string with your desired delimiters to get your final answer.

Did you try the code in your duplicate thread:

http://www.excelforum.com/excel-prog...g-a-macro.html

I'll see about tweaking it to remove duplicates.

Here's my take on my original macro from the other thread, switched to the Collections Method which will exclude duplicates automatically.

Option Explicit

Function JustMergeIt(mCOLs As Range, mVAL As Range, mRES As Range) As String
Dim cell As Range, m As Range, BUF As String
Dim c As Range, List As New Collection, Item As Variant

Set mVAL = mVAL.Cells(1)        'in case more than one cell is given, uses the first
If mVAL = "" Then Exit Function

Set mRES = Intersect(Sheets(mRES.Parent.Name).UsedRange, mRES)
On Error Resume Next

    For Each m In mCOLs.SpecialCells(xlConstants)
        If m = mVAL Then
            For Each cell In Intersect(mRES, Rows(m.Row))
                If cell <> "" Then List.Add cell.Value, CStr(cell.Value)
            Next cell
        End If
    Next m

    If List.Count > 0 Then
        For Item = 1 To List.Count
            BUF = BUF & "," & List(Item)
        Next Item
        
        JustMergeIt = Mid(BUF, 2, Len(BUF))
    Else
        JustMergeIt = "none"
    End If

End Function

Very nice, Jerry! With about 20,000 rows, your udf had an average runtime of ~0.63 seconds compared to mine of ~2.09 seconds which is roughly 230.24% faster. Its also nice to see collections in action, this is my first time seeing them used

I added a tweak above (in red) in case the second parameter comes up as a blank value, it won't run all that extra code for no benefit.

@JBeaucaire,
Is there a reason for using

Sheets(mRES.Parent.Name).UsedRange

rather than just

mRES.Parent.UsedRange

?

I haven't tested, but would expect that loading the ranges into arrays before looping, and using a Dictionary rather than a Collection (assuming not on a Mac) to be a little faster if performance is a real issue, since Dictionaries are more lightweight than Collections, and you should also be able to output the final string using Join rather than a loop.

or

Sub tst8()
 msgbox = snb5(Columns(1), "A1", Columns("D:F"))
End Sub

Function snb5(sn As Range, c01 As String, sq As Range)
 sp = sn.Parent.UsedRange
 For j = 2 To UBound(sp)
  c02 = c02 & "_|_" & Join(Application.Index(sp, j), "_")
 Next
   
 sz = Split(Join(Filter(Split(c02, "|"), "_" & c01 & "_"), ""), "_")
 For j = sq.Columns(1).Column To sq.Columns(1).Column + sq.Columns.Count
  If InStr(c03 & "_", "_" & sz(j) & "_") = 0 And sz(j) <> "" Then c03 = c03 & "_" & sz(j)
 Next
 snb5 = Mid(c03, 2)
End Function

NB. the contatenation of the whole table into 1 string you only have to perform once.
Now I made it a part of the function.
If you can store that concatenated string somewhere you can use it every time in the function without any need to build it anew.
It can speed up the code dramatically.

@OnErrorGoto0 - no, I just do what my brain suggests and works. I don't have an overwhelming opinion about Dictionaries vs Collections, it's all just a learning curve.

I do what makes sense to me and can be written out in a manner I "think" will be easy for the OPs to absorb. I marvel at SNB's tight little codes, but could seldom in good conscience offer them myself in the form he uses, it's simply too far advanced in presentation. However, I do learn from it, so, the more the merrier I say.

In the end, the OP will choose what works reliably and is understandable and "hopefully" they can then adapt and maintain on their own.