***************************************************************
指定Rangeに指定罫線が格子状に引かれているか判定
【引数】Range ：対象のRange
【引数】Style ：罫線のスタイル
【引数】Color ：罫線の色
【引数】Weight ：罫線の太さ
***************************************************************
Option Explicit
Option Private Module
Public Enum E_Borders
DiagonalDown = 2 ^ 0
DiagonalUp = 2 ^ 1
EdgeLeft = 2 ^ 2
EdgeTop = 2 ^ 3
EdgeBottom = 2 ^ 4
EdgeRight = 2 ^ 5
InsideVertical = 2 ^ 6
InsideHorizontal = 2 ^ 7
End Enum
Public Function fRange_Border_Is田(Range As Range, _
Optional Style As XlLineStyle = xlContinuous, _
Optional Color As Long = vbBlack, _
Optional Weight As XlBorderWeight = xlThin) As Boolean
Dim Borders As E_Borders
Borders = E_Borders.EdgeBottom + E_Borders.EdgeLeft + E_Borders.EdgeRight + E_Borders.EdgeTop
'セルアドレス判定用の辞書
Dim Dic As Scripting.Dictionary
Set Dic = New Scripting.Dictionary
Dim Cell As Range
For Each Cell In Range.Cells
'結合セルを取得
Dim Rng As Range
Set Rng = Cell.MergeArea
'結合セルのアドレスで初めての場合
Dim Address As String
Address = Rng.Address(False, False)
If Dic.Exists(Address) = False Then
Dic.Item(Address) = Empty
If fRange_Borders_Exists(Rng, Borders, Style, Color, Weight) = False Then Exit Function
End If
Next
fRange_Border_Is田 = True
End Function
Public Function fRange_Borders_Exists(Range As Range, Borders As E_Borders, _
Optional Style As XlLineStyle = xlContinuous, _
Optional Color As Long = -1, _
Optional Weight As XlBorderWeight = 0) As Boolean
With Range
Dim Code As Variant
For Each Code In Array(E_Borders.EdgeTop, E_Borders.EdgeLeft, _
E_Borders.EdgeRight, E_Borders.EdgeBottom, _
E_Borders.InsideHorizontal, E_Borders.InsideVertical, _
E_Borders.DiagonalDown, E_Borders.DiagonalUp)
'対象の罫線の場合(※引数で複数選択可)
If Code And Borders Then
'※結合セルの一部欠けに対応
Dim Area As Range
Set Area = Nothing
If .Cells.Count > 1 Then
Select Case Code
Case E_Borders.EdgeTop: Set Area = .Resize(1)
Case E_Borders.EdgeLeft: Set Area = .Resize(, 1)
Case E_Borders.EdgeRight: Set Area = .Cells(1, .Columns.Count).Resize(.Rows.Count)
Case E_Borders.EdgeBottom: Set Area = .Cells(.Rows.Count, 1).Resize(, .Columns.Count)
End Select
End If
'指定方向を１セルずつ確かめたい場合
If Area Is Nothing = False Then
Dim Cell As Range
For Each Cell In Area.Cells
If fRange_Borders_Exists(Cell, CLng(Code), Style, Color, Weight) = False Then Exit Function
Next
Else
'各種設定が一致するか判定
Dim Index As XlBordersIndex
Index = prBorder_Code_to_Index(CLng(Code))
With Range.Borders(Index)
'罫線の有無
If .LineStyle <> Style Then Exit Function
'罫線がある場合
If Color >= 0 Then If .Color <> Color Then Exit Function
If Weight > 0 Then If .Weight <> Weight Then Exit Function
End With
End If
End If
Next
End With
fRange_Borders_Exists = True
End Function
Private Function prBorder_Code_to_Index(Code As E_Borders) As XlBordersIndex
Dim Index As XlBordersIndex
Select Case Code
Case E_Borders.DiagonalDown: Index = xlDiagonalDown
Case E_Borders.DiagonalUp: Index = xlDiagonalUp
Case E_Borders.EdgeBottom: Index = xlEdgeBottom
Case E_Borders.EdgeLeft: Index = xlEdgeLeft
Case E_Borders.EdgeRight: Index = xlEdgeRight
Case E_Borders.EdgeTop: Index = xlEdgeTop
Case E_Borders.InsideHorizontal: Index = xlInsideHorizontal
Case E_Borders.InsideVertical: Index = xlInsideVertical
End Select
prBorder_Code_to_Index = Index
End Function