merging cells with Merge excel wizard, but need to repeat 30 000 times

[dragmast]

Hi everyone.

I am working now on creating a file with data and I needed a special merge options, so I bought Merge cells wizard. The add-in is doing just fine. But it seems that I have to repeat an operation more than 30 000 times. This is what I am doing:

in cell A1 I have a word, for ex. "tree" in cells B1 B2, B3 (the number varies with every word in A1, A5....etc.) I have synonyms. I need all the words from B1, B2,B3.... to be merged only in B1. Here I use Merge cells wizard.

It looks like this before merging:

word (in 1 cell) explanation 1
explanation 2
explanation 3....
........ (all the explanations are in different cells)
after merging:

word (in 1 cell) explanation 1
explanation 2
explanation 3....
........ (all the explanations are in THE SAME cell)

So if you have any ideas of how to apply this to all the worksheet, please let me know

Best regards

 

[mikerickson]

You might use this UDF.
If you have words in column A and synonyms in column B

=ConcatIf(A:A, "cat", B:B, ",") will return all the synonyms of "cat"
=ConcatIf(A:A, "cat", B:B, ",", TRUE) will insure that there are no duplicates.

Function ConcatIf(ByVal compareRange As Range, ByVal xCriteria As Variant, Optional ByVal stringsRange As Range, _
                    Optional Delimiter As String, Optional NoDuplicates As Boolean) As String
                    
    Rem the first three argumens of ConcatIf mirror those of SUMIF
    Rem the Delimiter and NoDuplicates arguments are optional (default "" and False)
    Dim i As Long, j As Long
    
    With compareRange.Parent
        Set compareRange = Application.Intersect(compareRange, Range(.UsedRange, .Range("a1")))
    End With
    
    If compareRange Is Nothing Then Exit Function
    If stringsRange Is Nothing Then Set stringsRange = compareRange
    Set stringsRange = compareRange.Offset(stringsRange.Row - compareRange.Row, _
                                            stringsRange.Column - compareRange.Column)
    
    For i = 1 To compareRange.Rows.Count
        For j = 1 To compareRange.Columns.Count
            If (Application.CountIf(compareRange.Cells(i, j), xCriteria) = 1) Then
                If InStr(ConcatIf, Delimiter & CStr(stringsRange.Cells(i, j))) <> 0 Imp Not (NoDuplicates) Then
                    ConcatIf = ConcatIf & Delimiter & CStr(stringsRange.Cells(i, j))
                End If
            End If
        Next j
    Next i
    ConcatIf = Mid(ConcatIf, Len(Delimiter) + 1)
End Function

 

[dragmast]

Thank you very much for the quick response. The solution works great !!!
Great respect for the knowledge and the kindness!!! Your forum is THE BEST )

 

[Peter_SSs]

Perhaps I have not understood correctly, but I thought that your data was like what I have shown in column A:B and you wanted results like in column C. I have assumed a heading row.

Excel Workbook
	A	B	C
1	Words	Meanings
2	word 1	Meaning 1	Meaning 1, Meaning 2, Meaning 3
3		Meaning 2
4		Meaning 3
5	word 2	Meaning 4	Meaning 4
6	word 3	Meaning 5	Meaning 5, Meaning 6
7		Meaning 6
8	word 4	Meaning 7	Meaning 7, Meaning 8, Meaning 9, Meaning 10
9		Meaning 8
10		Meaning 9
11		Meaning 10
12	word 5	Meaning 11	Meaning 11, Meaning 12
13		Meaning 12
14
Merge Meanings

A suggested code to do that is:

<font face=Courier New><br><br><SPAN style="color:#00007F">Sub</SPAN> CollectMeanings()<br>    <SPAN style="color:#00007F">Dim</SPAN> lr <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, i <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, k <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <SPAN style="color:#00007F">Dim</SPAN> ab, c<br><br>    lr = Range("B" & Rows.Count).End(xlUp).Row<br>    <SPAN style="color:#00007F">ReDim</SPAN> c(1 <SPAN style="color:#00007F">To</SPAN> lr, 1 <SPAN style="color:#00007F">To</SPAN> 1)<br>    ab = Range("A1").Resize(lr, 2).Value<br>    <SPAN style="color:#00007F">For</SPAN> i = 2 <SPAN style="color:#00007F">To</SPAN> lr<br>        <SPAN style="color:#00007F">If</SPAN> ab(i, 1) = "" <SPAN style="color:#00007F">Then</SPAN><br>            c(k, 1) = c(k, 1) & ", " & ab(i, 2)<br>        <SPAN style="color:#00007F">Else</SPAN><br>            k = i<br>            c(k, 1) = ab(i, 2)<br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>    <SPAN style="color:#00007F">Next</SPAN> i<br>    <SPAN style="color:#00007F">With</SPAN> Range("C1").Resize(lr)<br>        .Value = c<br>        .EntireColumn.AutoFit<br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br></FONT>

A couple of extra lines could be added to the code if you wanted to remove the original column (B) and/or the blank rows in column C so that you were left with only rows showing the combined meanings so that you ended up with something like this:

Excel Workbook
	A	B
1	Words	Meanings
2	word 1	Meaning 1, Meaning 2, Meaning 3
3	word 2	Meaning 4
4	word 3	Meaning 5, Meaning 6
5	word 4	Meaning 7, Meaning 8, Meaning 9, Meaning 10
6	word 5	Meaning 11, Meaning 12
7
Merge Meanings

 

[dragmast]

Thanks a lot for the efforts. Everything works perfect!!!