やりたいこと

このマクロは、悪名高きExcel方眼紙で書類を作るときに使うマクロです。
(できれば使いたくないけど、会社や取引先の都合でExcel方眼紙のフォームを使わざるを得ない、、、)

具体的には、複数のセルが罫線で囲まれた範囲を結合したいというのがこのマクロの目的。(下図参照)

使い方

後述のコードを、Excel VBAの標準モジュールにコピーすれば、そのまま使用できます。

範囲を選択し、Alt+8のショートカットからマクロを呼び出し実行します

　
いろいろな罫線に対してこのマクロを実行できます。
ただし、罫線で囲まれた複数の異なるセルにテキストが入力してあると、エラーになります。
この点は、セル結合時にデータもマージするExcelマクロを組み合わせれば解決しますね。(個人的には必要性が薄かったので、組み込めてないです)

(わかりやすくするため、マージした範囲を黄色で色付してます)

コード

下記のコードをExcel VBAの標準モジュールにコピーすればすぐに使えます。

Module1.bas

Attribute VB_Name = "Module1"
Option Explicit

Public Sub mergeInBoader()
    Dim setRng As Range, mergeRng As Range, iRng As Range
    
    Const NG As Integer = -4142 '罫線なし
    Const OK As Integer = 1 '罫線あり
    
    If TypeName(Selection) <> "Range" Then Exit Sub
    Set setRng = Selection
    
    For Each iRng In setRng
        If iRng.Borders(xlEdgeTop).LineStyle = OK And _
            iRng.Borders(xlEdgeLeft).LineStyle = OK Then '左と上に罫線があるとき
            
            Set mergeRng = mergeRight(iRng, setRng, OK, NG) '右の罫線までの範囲を抽出
            Set mergeRng = mergeBottom(mergeRng, setRng, OK, NG) '下の罫線までの範囲を抽出
            Set mergeRng = checkBoader(mergeRng, OK, NG) '枠線が途切れてないか/内側に罫線がないかを確認
            
            If Not mergeRng Is Nothing Then
                mergeRng.Merge '抽出範囲をマージする
            End If
        End If
    Next
End Sub

Private Function mergeRight(ByRef iRng As Range, ByRef setRng As Range, ByVal OK As Integer, ByVal NG As Integer) As Range

    Dim i As Long
    Dim iCount As Long

    Set mergeRight = iRng
    
    If iRng.Borders(xlEdgeRight).LineStyle = OK Then Exit Function    'iRngの右に罫線があれば終了
    
    'iRngの右に罫線がない場合、mergeRightの範囲を右に拡大
    i = 0
    iCount = setRng(1, setRng.Columns.Count).Column - iRng.Column + 1
    
    Do While i < iCount
        If iRng.Offset(0, i).Borders(xlEdgeRight).LineStyle = NG Then '右に罫線がない場合
            Set mergeRight = Union(mergeRight, iRng.Offset(0, i + 1))
            i = i + 1
        Else '右に罫線がある場合
            i = Columns.Count
        End If
    Loop
    
    If i <> Columns.Count Then     '抽出範囲の右端まで罫線がなかった場合
        Set mergeRight = Nothing
    End If
    
End Function

Private Function mergeBottom(ByRef iRng As Range, ByRef setRng As Range, ByVal OK As Integer, ByVal NG As Integer) As Range

    Dim i As Long
    Dim iCount As Long
    
    Set mergeBottom = iRng

    If iRng Is Nothing Then Exit Function   'エラー処理
    If iRng.Borders(xlEdgeBottom).LineStyle = OK Then Exit Function    'iRngの下に罫線があれば終了

    'iRngの下に罫線がない場合、mergeBottomの範囲を下に拡大
    i = 0
    iCount = setRng(setRng.Rows.Count, 1).Row - iRng.Row + 1
    
    Do While i < iCount
        If iRng.Offset(i, 0).Borders(xlEdgeBottom).LineStyle = NG Then '下に罫線がない場合
            Set mergeBottom = Union(mergeBottom, iRng.Offset(i + 1, 0))
            i = i + 1
        Else '下に罫線がある場合
            i = Rows.Count
        End If
    Loop

    If i <> Rows.Count Then     '抽出範囲の下端まで罫線がなかった場合
        Set mergeBottom = Nothing
    End If

End Function

Private Function checkBoader(ByRef mergeRng As Range, ByVal OK As Integer, ByVal NG As Integer) As Range

    Dim iRng As Range
    Dim i As Long, j As Long

    Set checkBoader = mergeRng
    If mergeRng Is Nothing Then Exit Function   'エラー処理
      
    For i = 1 To mergeRng.Rows.Count
        For j = 1 To mergeRng.Columns.Count
            Set iRng = mergeRng(i, j)  'マージ予定領域の各レンジについて評価
            
            ' 領域の端に枠線があるか確認
            If i = 1 And iRng.Borders(xlEdgeTop).LineStyle = NG Then Set checkBoader = Nothing '上側
            If i = mergeRng.Rows.Count And iRng.Borders(xlEdgeBottom).LineStyle = NG Then Set checkBoader = Nothing '下側
            If j = 1 And iRng.Borders(xlEdgeLeft).LineStyle = NG Then Set checkBoader = Nothing '左側
            If j = mergeRng.Columns.Count And iRng.Borders(xlEdgeRight).LineStyle = NG Then Set checkBoader = Nothing '右側
            
            ' 領域の内側に罫線がないか確認
            If mergeRng.Rows.Count = 1 Or mergeRng.Columns.Count = 1 Then Exit Function '一列/一行の場合はCheck除外
            If i <> 1 And iRng.Borders(xlEdgeTop).LineStyle = OK Then Set checkBoader = Nothing '上端以外の上側
            If i <> mergeRng.Rows.Count And iRng.Borders(xlEdgeBottom).LineStyle = OK Then Set checkBoader = Nothing '下端以外の下側
            If j <> 1 And iRng.Borders(xlEdgeLeft).LineStyle = OK Then Set checkBoader = Nothing '左端以外の左側
            If j <> mergeRng.Columns.Count And iRng.Borders(xlEdgeRight).LineStyle = OK Then Set checkBoader = Nothing '右端以外の右側
            
        Next
    Next

End Function

参考