Option Explicit
Sub unmerge_fill_values()
'Erik Van Geit
'060925
'unmerge and put value in mergearea
'EXAMPLE
'START WITH
'D1:E3 merged, value = "abc"
'RESULT
'D1:E3 unmerged, D1, D2, D3, E1, E2, E3 get "abc"
Dim LR As Long 'Last Row
Dim LC As Integer 'Last Column
Dim i As Long
Dim j As Integer
Dim mergeRng As Range
Dim checkmerged As Boolean
Dim AppSetCalc As Integer
With Application
.ScreenUpdating = False
AppSetCalc = .Calculation
.Calculation = xlCalculationManual
End With
With ActiveSheet
'needing xlCellTypeLastCell: else if last cell is merged wrong area will be found
LR = .Cells.SpecialCells(xlCellTypeLastCell).Row
LC = .Cells.SpecialCells(xlCellTypeLastCell).Column
With .Cells(LR, LC)
If .MergeCells Then
LR = LR + .MergeArea.Rows.Count - 1
LC = LC + .MergeArea.Columns.Count - 1
End If
End With
If .Range(.Cells(1, 1), .Cells(LR, LC)).MergeCells = False Then
MsgBox "no merged cells on this sheet", 48, "EXIT"
Exit Sub
End If
For i = 1 To LR
On Error Resume Next
checkmerged = .Range(.Cells(i, 1), .Cells(i, LC)).MergeCells
'error occurs when MergeArea intersects row and contains more rows
'checkmerged is TRUE when MergeArea is in one row
If Err Or checkmerged Then
Err.Clear
For j = 1 To LC
With .Cells(i, j)
Set mergeRng = .MergeArea
.UnMerge
mergeRng = .Value
End With
Next j
End If
Next i
End With
With Application
.ScreenUpdating = True
.Calculation = AppSetCalc
End With
End Sub