Descomponer una columna con celdas combinadas

Este es el resultado de la macro

Sub SEPARA()
Dim DATOS As Range
Dim F As Long, CUENTA As Long, I As Integer
Set DATOS = Range("A1").CurrentRegion
With DATOS
    .Columns(2).Clear
    F = .Rows.Count:    CUENTA = WorksheetFunction.CountA(DATOS)
    Areas = WorksheetFunction.Quotient(F, CUENTA)
    For I = 1 To F Step Areas
        VALOR = .Cells(I, 1):  .Cells(I, 2).Resize(Areas, 1) = VALOR
    Next I
    .CurrentRegion.EntireColumn.AutoFit
End With
End Sub

Adjunto código para la solución de consulta para su revisión.

Sub DescombinarCeldas()
For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
    If Range("A" & i).MergeCells = True Then
        Rango = Replace(Range("A" & i).MergeArea.Address(False, False), "A", "B")
        Range(Rango) = Range("A" & i).MergeArea.Cells(1, 1)
    End If
Next i
End Sub

Espero que te sirva de ayuda y este acorde de tu necesidad. Cualquier consulta estaré pendiente.

Por favor, no olvidar de valorar las respuestas.

Te anexo la macro

Sub Des_Combinar_Celdas()
'Por.Dante Amor
    Application.ScreenUpdating = False
    For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
        If Range("A" & i).MergeCells Then
            ini = Range("A" & i).MergeArea.Cells(1, 1).Row
            fin = Range("A" & i).MergeArea.Rows.Count + ini - 1
            Range("B" & ini & ":B" & fin).Value = Range("A" & i).Value
            i = fin
        Else
            Range("B" & i).Value = Range("A" & i).Value
        End If
    Next
    Application.ScreenUpdating = True
    MsgBox "fin"
End Sub

.

.