Unmerge VBA with dates

[AJK]

Hi All,

I got VBA code of this forum to unmerge and copy cells across. It was working perfectly until it came to the dates in a column. As it was using autocomplete I'm getting incremental values across the 5 column headings it unmerge. Can someone please help me with the code so it doesn't autofill incremental values as headings across the unmerged cells?

Thank you


Public Sub ProcessData()
Dim cell As Range
Dim MergedCell As Range
Dim NumRows As Long
Dim NumCols As Long

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
With ActiveSheet
For Each cell In Range("A1").Resize( _
.Cells.SpecialCells(xlCellTypeLastCell).Row, _
.Cells.SpecialCells(xlCellTypeLastCell).Column)
If cell.MergeCells Then
NumRows = cell.MergeArea.Rows.Count
NumCols = cell.MergeArea.Columns.Count
cell.UnMerge
If NumRows > 1 Then cell.AutoFill cell.Resize(NumRows)
If NumCols > 1 Then cell.Resize(NumRows).AutoFill cell.Resize(NumRows, NumCols)
End If
Next cell
End With
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub

[Bob Phillips]

Try this


Public Sub ProcessData()
Dim cell As Range
Dim MergedCell As Range
Dim NumRows As Long
Dim NumCols As Long

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
With ActiveSheet
For Each cell In Range("A1").Resize( _
.Cells.SpecialCells(xlCellTypeLastCell).Row, _
.Cells.SpecialCells(xlCellTypeLastCell).Column)
If cell.MergeCells Then
NumRows = cell.MergeArea.Rows.Count
NumCols = cell.MergeArea.Columns.Count
cell.UnMerge
If NumRows > 1 Then cell.AutoFill cell.Resize(NumRows), xlFillCopy
If NumCols > 1 Then cell.Resize(NumRows).AutoFill cell.Resize(NumRows, NumCols), xlFillCopy
End If
Next cell
End With
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub

[AJK]

Works brilliantly! Much appreciated, 😊


Try this


Public Sub ProcessData()
Dim cell As Range
Dim MergedCell As Range
Dim NumRows As Long
Dim NumCols As Long

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
With ActiveSheet
For Each cell In Range("A1").Resize( _
.Cells.SpecialCells(xlCellTypeLastCell).Row, _
.Cells.SpecialCells(xlCellTypeLastCell).Column)
If cell.MergeCells Then
NumRows = cell.MergeArea.Rows.Count
NumCols = cell.MergeArea.Columns.Count
cell.UnMerge
If NumRows > 1 Then cell.AutoFill cell.Resize(NumRows), xlFillCopy
If NumCols > 1 Then cell.Resize(NumRows).AutoFill cell.Resize(NumRows, NumCols), xlFillCopy
End If
Next cell
End With
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub