Created
March 21, 2018 02:21
-
-
Save igeta/0bfa57c2ebaa19a12ad7a95dc44f1a6e to your computer and use it in GitHub Desktop.
罫線で囲まれたセル範囲を取得する。これを直接マクロに組み込むのではなく、Excel方眼紙/帳票の分析に使用して、その分析結果をもとにVBA書くのがよいかと。
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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