VBA: Macro de Excel para combinar celdas y definirlas con las mismas dimensiones.

En el día de hoy expondré una manera de combinar diferentes celdas, así como definir su dimensión, para que independientemente de las celdas 'juntadas', todas tengan la misma altura.
En particular se trata de combinar ciertas celdas combinadas condicionadas a los valores del campo adyacente, de tal forma que para elementos iguales de ese segundo campo, nuestras celdas queden combinadas.
Se verá mejor en la siguiente imagen:

Como se aprecia, he copiado a la derecha tres Cuadrados de iguales dimensiones, para que visualmente se compruebe que efectivamente las alturas de las celdas combinadas son idénticas.
Por otro lado es importante remarcar el sentido de nuestra futura macro, y es que para el campo 'Nivel', se han combinado las celdas correspondientes del campo 'Imagen', para cada uno de los niveles, independientemente del número de elementos que hubiera (tres, dos o cuatro en el ejemplo).

Se trata de construir un procedimiento que identifique las celdas que contienen niveles
iguales. Esto lo realizaremos incluyendo una collection que detecte los saltos en el campo 'Nivel'. Nuestra Collection solo agrega elementos no repetidos, y en concreto en qué celda se encuentra el nuevo elemento.
Con esas direcciones de las celdas donde existen saltos o cambios de 'Nivel' construiremos posteriormente los rangos de las celdas a combinar.
Por ejemplo, la primera celda sería A2 y el siguiente salto en A4, el siguiente en A5 hasta A6 y el último en el ejemplo de A7 hasta el elemento inluido manualmente en la Collection que es A10. Los rangos combinados serán por tanto A2:A4, A5:A6 y A7:A10.

Así que, en un módulo del Editor de VBA añadiremos las líneas de nuestra macro.

Sub MergeCondicionado()
Dim celda As Object
'generamos una coleccion
Set unicos = New Collection

For Each celda In Range("C2:C10")
    'controlamos el cambio de Nivel
    If celda.Value = celda.Offset(-1, 0).Value Then
    x = x + 0
    Else
    x = x + 1
    'cuando encuentre un item repetido, daría un error
    'que salvamos con la instrucción On Error Resume Next
    On Error Resume Next
    'por tanto, nuestra coleccion solo agrega elementos no repetidos
    'y en concreto en qué celda se encuentra el nuevo elemento
    unicos.Add celda.Offset(0, -2).Address, CStr(celda.Offset(0, -2).Address)
    On Error GoTo 0
    End If
Next celda

'añadimos a la colección un último elemento
unicos.Add Range("C10").Offset(1, -2).Address

'Combinamos las celdas desde un elemento de la colección al siguiente
For j = 1 To unicos.Count - 1
Range(unicos(j), Range(unicos(j + 1)).Offset(-1, 0)).Merge
Next j

'configuramos el ancho y alto homogeneo de todas las celdas combinadas
For i = 1 To unicos.Count - 1
    'damos un ancho a la columna
    Range(unicos(i), Range(unicos(i + 1)).Offset(-1, 0)).EntireColumn.ColumnWidth = 25
    'damos un alto a las celdas combinadas para que todas queden de igual altura
    Range(unicos(i), Range(unicos(i + 1)).Offset(-1, 0)).EntireRow.RowHeight = _
        50 / Application.WorksheetFunction.CountIf(Range("C2:C10"), Range(unicos(i)).Offset(0, 2).Value)
Next i
End Sub

Podemos comparar el resultado final de la primera imagen con el punto de partida...