Merge Same Cells

Question

I want to merge the cells that has same values into one cell as shown below.

Before

After

There is a simple macro, problem with it is, I have to run it multiple times on each column until all cells are merged. Not very ideal when I have thousands of rows. Do While might go into infinite loop?

Dim rng As Range

For Each rng In Selection

    If rng.Value = rng.Offset(1, 0).Value And rng.Value <> "" Then 

    Range(rng, rng.Offset(1, 0)).Merge 

    Range(rng, rng.Offset(1, 0)).HorizontalAlignment = xlCenter 

    Range(rng, rng.Offset(1, 0)).VerticalAlignment = xlCenter

End if

Next

Answer 1

Well... merged cells are in most cases a bad idea, they cause always trouble when you process further.

Anyway, a basic idea:

Intersect the current selection with the used range to remove unused cells

Get all unique values from the data, skip empty cells

Search the selection for all unique values

Try to merge this cells

The code below might be helpful. Before you copy the code below into your file please read this article:
VBA issues with new forum editor - Microsoft Community

Andreas.

Function UniqueItems(ByVal R As Range, _
Optional ByVal Compare As VbCompareMethod = vbBinaryCompare, _
Optional ByRef Count) As Variant
'Return an array with all unique values in R
' and the number of occurrences in Count
Dim Area As Range, Data
Dim i As Long, j As Long
Dim Dict As Object 'Scripting.Dictionary
Set R = Intersect(R.Parent.UsedRange, R)
If R Is Nothing Then
UniqueItems = Array()
Exit Function
End If
Set Dict = CreateObject("Scripting.Dictionary")
Dict.CompareMode = Compare
For Each Area In R.Areas
Data = Area
If IsArray(Data) Then
For i = 1 To UBound(Data)
For j = 1 To UBound(Data, 2)
If Not Dict.Exists(Data(i, j)) Then
Dict.Add Data(i, j), 1
Else
Dict(Data(i, j)) = Dict(Data(i, j)) + 1
End If
Next
Next
Else
If Not Dict.Exists(Data) Then
Dict.Add Data, 1
Else
Dict(Data) = Dict(Data) + 1
End If
End If
Next
UniqueItems = Dict.Keys
Count = Dict.Items
End Function

Function FindAll(ByVal Where As Range, ByVal What, _
Optional ByVal After As Variant, _
Optional ByVal LookIn As XlFindLookIn = xlValues, _
Optional ByVal LookAt As XlLookAt = xlWhole, _
Optional ByVal SearchOrder As XlSearchOrder = xlByRows, _
Optional ByVal SearchDirection As XlSearchDirection = xlNext, _
Optional ByVal MatchCase As Boolean = False, _
Optional ByVal SearchFormat As Boolean = False) As Range
'Find all occurrences of What in Where (Windows version)
Dim FirstAddress As String
Dim C As Range
'From FastUnion:
Dim Stack As New Collection
Dim Temp() As Range, Item
Dim i As Long, j As Long

If Where Is Nothing Then Exit Function
If SearchDirection = xlNext And IsMissing(After) Then
'Set After to the last cell in Where to return the first cell in Where in front if _
it match What
Set C = Where.Areas(Where.Areas.Count)
'BUG in XL2010: Cells.Count produces a RTE 6 if C is the whole sheet
'Set After = C.Cells(C.Cells.Count)
Set After = C.Cells(C.Rows.Count * CDec(C.Columns.Count))
End If

Set C = Where.Find(What, After, LookIn, LookAt, SearchOrder, _
SearchDirection, MatchCase, SearchFormat:=SearchFormat)
If C Is Nothing Then Exit Function

FirstAddress = C.Address
Do
Stack.Add C
If SearchFormat Then
'If you call this function from an UDF and _
you find only the first cell use this instead
Set C = Where.Find(What, C, LookIn, LookAt, SearchOrder, _
SearchDirection, MatchCase, SearchFormat:=SearchFormat)
Else
If SearchDirection = xlNext Then
Set C = Where.FindNext(C)
Else
Set C = Where.FindPrevious(C)
End If
End If
'Can happen if we have merged cells
If C Is Nothing Then Exit Do
Loop Until FirstAddress = C.Address

'FastUnion algorithm © Andreas Killer, 2011:
'Get all cells as fragments
ReDim Temp(0 To Stack.Count - 1)
i = 0
For Each Item In Stack
Set Temp(i) = Item
i = i + 1
Next
'Combine each fragment with the next one
j = 1
Do
For i = 0 To UBound(Temp) - j Step j * 2
Set Temp(i) = Union(Temp(i), Temp(i + j))
Next
j = j * 2
Loop Until j > UBound(Temp)
'At this point we have all cells in the first fragment
Set FindAll = Temp(0)
End Function

Answer 2

What range needs to be selected for R and Compare arguments? and there is FindAll function as well.

Answer 3

You can not use that as UDF, this functions are for the use in VBA.

Andreas.

Sub Test()
Dim Items
Items = UniqueItems(Selection, vbTextCompare)
MsgBox Join(Items, ","), vbOKCancel, UBound(Items) - LBound(Items) + 1 & " Items"
End Sub

Answer 4

The above huge code is not a sub procedure how to run it? name does not show up in the macro list.

If possible can you run it from your side and share the workbook?

Answer 5

There is no main routine to run, I leave that to you. Using the functions from above, which does the most work, is not so difficult.

The point is you need to understand the code, because what you're trying to do is IMHO critical and the code can fail in many scenarios, e.g. you can not merge A1 and C3 or what happens if you already have merged cells and want to add cells?

You have been here in the forum for a while and have got to know and used different VBA codes, today is the day when you should take the next step and write your first code yourself.

Andreas.