やりたいこと
このマクロは、悪名高き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