Skip to content

Instantly share code, notes, and snippets.

@igeta
Created March 21, 2018 02:21
Show Gist options
  • Save igeta/0bfa57c2ebaa19a12ad7a95dc44f1a6e to your computer and use it in GitHub Desktop.
Save igeta/0bfa57c2ebaa19a12ad7a95dc44f1a6e to your computer and use it in GitHub Desktop.
罫線で囲まれたセル範囲を取得する。これを直接マクロに組み込むのではなく、Excel方眼紙/帳票の分析に使用して、その分析結果をもとにVBA書くのがよいかと。
Option Explicit
Sub TestRun()
Dim wf As WorksheetFunction: Set wf = WorksheetFunction
Dim rng As Range, r As Range, arr As Variant
For Each rng In BorderedCells(Sheet1.UsedRange)
Debug.Print "[" & rng.Address(False, False) & "] ";
For Each r In rng.Rows
If r.Cells.Count > 1 Then
arr = wf.Transpose(wf.Transpose(r.Value))
Else
arr = Array(r.Value)
End If
Debug.Print Join(arr, "")
Next
Next
End Sub
Public Function BorderedCells(ByVal rng As Range) As Collection
Dim r As Range, r2 As Range, flg As Boolean, addr As String
Dim tplf As Collection: Set tplf = New Collection
For Each r In rng
If r.Borders(xlEdgeLeft).LineStyle <> xlLineStyleNone _
And r.Borders(xlEdgeTop).LineStyle <> xlLineStyleNone Then
tplf.Add r
End If
Next
On Error GoTo Err1004
Dim ret As Collection: Set ret = New Collection
For Each r In tplf
addr = r.Address
While r.MergeArea.Borders(xlEdgeTop).LineStyle <> xlLineStyleNone _
And r.MergeArea.Borders(xlEdgeRight).LineStyle = xlLineStyleNone
Set r = r.Offset(, 1)
Wend
If r.MergeArea.Borders(xlEdgeTop).LineStyle = xlLineStyleNone Then
Set r = r.Offset(, -1)
End If
While r.MergeArea.Borders(xlEdgeRight).LineStyle <> xlLineStyleNone _
And r.MergeArea.Borders(xlEdgeBottom).LineStyle = xlLineStyleNone
Set r = r.Offset(1)
Wend
If r.MergeArea.Borders(xlEdgeRight).LineStyle = xlLineStyleNone Then
Set r = r.Offset(-1)
End If
Set r2 = r
While r.MergeArea.Borders(xlEdgeBottom).LineStyle <> xlLineStyleNone _
And r.MergeArea.Borders(xlEdgeLeft).LineStyle = xlLineStyleNone
Set r = r.Offset(, -1)
Wend
If r.MergeArea.Borders(xlEdgeBottom).LineStyle = xlLineStyleNone Then
Set r = r.Offset(, 1)
End If
While r.MergeArea.Borders(xlEdgeLeft).LineStyle <> xlLineStyleNone _
And r.MergeArea.Borders(xlEdgeTop).LineStyle = xlLineStyleNone
Set r = r.Offset(-1)
Wend
If r.MergeArea.Borders(xlEdgeLeft).LineStyle = xlLineStyleNone Then
Set r = r.Offset(1)
End If
If r.Address = addr Then
Set r = Range(r, r2)
If rng.Address = Union(rng, r).Address Then ret.Add r
End If
Next
On Error GoTo 0
GoTo Ending:
Err1004:
If Err.Number = 1004 Then Resume Next
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
Ending:
Set BorderedCells = ret
End Function
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment