【Excel】セル結合されたダメ表を一気に結合解除・整形するVBAマクロ

Excelで既存の表を再利用しようとした時、下図のような表しかなく、愕然としたことはないでしょうか。

見ばえを良くしようとした結果（？）、セルが上下左右に結合されまくっていて、オートフィルターもまともに機能しない、集計もできない、VLOOKUPもちゃんとひっかからない、あげく、コピー＆ペーストすらうまくいかなかったり・・・

私も事務仕事に従事している都合上、このようなダメダメデータに困らされることがありましたので、一発で使えるデータに整形するマクロをVBAで作成しました。

完成したマクロの動作
使い方
ソースコード
まとめ

完成したマクロの動作

作成したマクロの動作は下記のような感じです。
ダメダメな結合しまくり表が、一発で整ったデータに整形できます。

縦にも横にも結合されまくりのデータを使えるデータに整形するマクロができたぞ#セル結合 #Excel方眼紙 pic.twitter.com/flzuOebSvZ
— ichi3270 (@ichi3270) May 17, 2020

使い方

こちらからダウンロードしてご利用ください。

以下、一番簡単な方法のみ説明します。

ダウンロードした「結合された表をどうにかする.xlsm」を開く
整形したい表が含まれているExcelファイルを開く
整形したい表の範囲を選択した状態で ALT キーを押しながら f8 キーを押す
結合された表をどうにかする.xlsm!結合された表を整形するを選択し実行(R)

上記手順を行えば、新しいシートに整形後の表が作成されます。

ソースコード

拙いですが、ソースコードを掲載します。
私のプログラミング能力は全然高くないので、不備とか改善点などあるかと思います。お気づきの点などありましたら、コメント欄等でご連絡いただけますと幸いです。

Option Explicit

Sub 結合された表を整形する()

'初期処理
Application.ScreenUpdating = False

'選択範囲の確認
If Selection.Count = 1 Then
    MsgBox ("処理する対象範囲を選択してから実行してください")
    Exit Sub
End If

'選択範囲の情報取得/コピー
Dim RowCnt As Long: RowCnt = Selection(Selection.Count).Row - Selection(1).Row + 1
Dim ColCnt As Long: ColCnt = Selection(Selection.Count).Column - Selection(1).Column + 1
Selection.Copy

'処理結果シートの作成
Dim OutWs As Worksheet
Set OutWs = Worksheets.Add(After:=Worksheets(Worksheets.Count))

'処理結果シートに元表をペースト
OutWs.Paste Destination:=Range("A1")

'Excel方眼紙を通常の表に修正する
Dim r As Long
For r = RowCnt To 1 Step -1
    If WorksheetFunction.CountA(Range(Cells(r, 1), Cells(r, ColCnt))) = 0 Then
        Rows(r).Delete
        RowCnt = RowCnt - 1
    End If
Next r

Dim c As Long
For c = ColCnt To 1 Step -1
    If WorksheetFunction.CountA(Range(Cells(1, c), Cells(RowCnt, c))) = 0 Then
        Columns(c).Delete
        ColCnt = ColCnt - 1
    End If
Next c

'結合解除/データ複製
Dim MgArea As Range
Dim Rng
For r = 1 To RowCnt
    For c = 1 To ColCnt
        If Cells(r, c).MergeCells Then
            Set MgArea = Cells(r, c).MergeArea
            MgArea.UnMerge
            Cells(r, c).Copy
            For Each Rng In MgArea
                Rng.PasteSpecial
            Next Rng
        End If
    Next c
Next r

'外観を整える
Cells.Rows.AutoFit
Cells.Columns.AutoFit
Range(Cells(1, 1), Cells(RowCnt, ColCnt)).Borders.LineStyle = True

'終了処理
Application.ScreenUpdating = True
MsgBox ("表の整形が完了しました")

End Sub

このコードの主な部分は、下記の部分だと思います。

If Cells(r, c).MergeCells Then
    Set MgArea = Cells(r, c).MergeArea
    MgArea.UnMerge
    Cells(r, c).Copy
    For Each Rng In MgArea
        Rng.PasteSpecial
    Next Rng
End If

表の左上からスタートして、右下に向かって全セルをチェックしていく中で、
セルが結合されているかどうかを、.MergeCellsで判定します。

結合されていた場合は、.MergeAreaで結合されているセルのRangeを取得します。

その後、.Unmergeで結合を解除。
結合を解除すると、結合されていたセルは一番左上のセル以外は空白になってしまうので、一番左上のセルをコピー・ペーストします。

これを表の全セル分行えば、整形が完了です。