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