Skip to content

Instantly share code, notes, and snippets.

@m-haketa
Created December 16, 2020 11:18
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
Star You must be signed in to star a gist
Save m-haketa/870ad91e328c73d55a38e16ed1f8812e to your computer and use it in GitHub Desktop.
罫線で囲まれた内側のセルに色を塗る
Option Explicit
Dim WS As Worksheet
Dim maxY As Long
Dim maxX As Long
Dim Outside As Variant
Dim toBeChecked As Collection
Sub main()
Set WS = Worksheets("data")
maxY = WS.UsedRange.Row + WS.UsedRange.Rows.Count
maxX = WS.UsedRange.Column + WS.UsedRange.Columns.Count
ReDim Outside(1 To maxY, 1 To maxX)
Set toBeChecked = New Collection
Dim y As Long
Dim x As Long
For x = 1 To maxX
checkEdgeCell 1, x, xlEdgeTop
checkEdgeCell maxY, x, xlEdgeBottom
Next
For y = 1 To maxY
checkEdgeCell y, 1, xlEdgeLeft
checkEdgeCell y, maxX, xlEdgeRight
Next
Do While toBeChecked.Count > 0
Dim Cell
Cell = Split(toBeChecked(1), ",")
toBeChecked.Remove 1
checkCell CLng(Cell(0)), CLng(Cell(1))
Loop
For y = 1 To maxY
For x = 1 To maxX
If Outside(y, x) <> 1 Then
WS.Cells(y, x).Interior.Color = vbYellow
End If
Next
Next
End Sub
Function noBorder(y As Long, x As Long, edge As XlBordersIndex) As Boolean
noBorder = WS.Cells(y, x).Borders(edge).LineStyle = xlLineStyleNone
End Function
Sub addToBeChecked(y As Long, x As Long)
If y <= 0 Or x <= 0 Or y > maxY Or x > maxX Then Exit Sub
If Outside(y, x) = 1 Then Exit Sub
toBeChecked.Add Join(Array(y, x), ",")
Outside(y, x) = 1
End Sub
Sub checkEdgeCell(y As Long, x As Long, edge As XlBordersIndex)
If noBorder(y, x, edge) Then addToBeChecked y, x
End Sub
Sub checkCell(y As Long, x As Long)
If noBorder(y, x, xlEdgeTop) Then addToBeChecked y - 1, x
If noBorder(y, x, xlEdgeBottom) Then addToBeChecked y + 1, x
If noBorder(y, x, xlEdgeLeft) Then addToBeChecked y, x - 1
If noBorder(y, x, xlEdgeRight) Then addToBeChecked y, x + 1
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment