VBA 選択範囲のセル結合を解除し値埋めするマクロ

列や行で選択しても使えるマクロメモ。

対象は↓のようにセル結合された表。

Sub UnmergeSelectionAndFillValues()
    Dim rng As Range
    Dim targetRng As Range
    Dim cnt As Long

    cnt = 0

    '画面更新OFF
    Application.ScreenUpdating = False
    
    '選択範囲のうち使用されている範囲を取得
    Set targetRng = Intersect(Selection, ActiveSheet.UsedRange)
    
    '対象範囲の各セルをループ
    For Each rng In targetRng
        '結合セルのみ処理
        If rng.MergeCells Then
            With rng.MergeArea
                '結合範囲のセル結合解除
                .UnMerge
                '結合されていた範囲の一番左上の値を範囲全体にセット
                .Value = rng.Value
            End With
            
            'カウントアップ
            cnt = cnt + 1
            
            'ステータスバーに処理進行状況を表示
            Application.StatusBar = "処理中..." & String(Int(cnt / 10), "■")
        End If
    Next
    
    'ステータスバー解放
    Application.StatusBar = False
    
    '画面更新ON
    Application.ScreenUpdating = True
End Sub

縦に同じ値のセルが入っていたら一番上のセル以外の文字色を白くし上罫線を繰りクリアする機能を追加すると以下のようになる。

Sub UnmergeSelectionAndFillValues()
    Dim rng As Range
    Dim targetRng As Range
    Dim cnt As Long

    cnt = 0

    '画面更新OFF
    Application.ScreenUpdating = False
    
    '選択範囲のうち使用されている範囲を取得
    Set targetRng = Intersect(Selection, ActiveSheet.UsedRange)
    
    '対象範囲の各セルをループ
    For Each rng In targetRng
        '結合セルのみ処理
        If rng.MergeCells Then
            With rng.MergeArea
                '結合範囲のセル結合解除
                .UnMerge
                '結合されていた範囲の一番左上の値を範囲全体にセット
                .Value = rng.Value
            End With
            
            'カウントアップ
            cnt = cnt + 1
            
            'ステータスバーに処理進行状況を表示
            Application.StatusBar = "処理中..." & String(Int(cnt / 10), "■")
        End If
    Next
    
    '選択範囲において1行上のセルと同じ値が入っているセルの文字色を白色にし上罫線クリア
    Call WhitenSuspendedCharOfSelection
    
    'ステータスバー解放
    Application.StatusBar = False
    
    '画面更新ON
    Application.ScreenUpdating = True
End Sub

'選択範囲において1行上のセルと同じ値が入っているセルの文字色を白色にし上罫線クリア
Sub WhitenSuspendedCharOfSelection()
    Dim rng As Range
    Dim targetRng As Range
    
    '選択範囲のうち使用されている範囲を取得
    Set targetRng = Intersect(Selection, ActiveSheet.UsedRange)

    '対象範囲の各セルをループ
    For Each rng In targetRng
        '1行上のセルと同じ値なら文字色を白色にし上罫線クリア
        If rng.Value = rng.Offset(-1).Value Then
            rng.Characters.Font.Color = vbWhite
            rng.Borders(xlEdgeTop).LineStyle = xlLineStyleNone
        End If
    Next
End Sub

B列を選択してマクロ実行すると↓のようになる。

参考記事

【エクセルVBA】一瞬で結合セルを解除して値を埋めるマクロ
https://www.excelspeedup.com/ketsugoukaijyoshiteumeru/