Borders All Around

I was reading How to Win at Monopoly (via Kottke.org). On Table 1, a range of cells was outlined.

Strangely (or maybe not so strangely), I thought about the most efficient way to do that in Excel. I don’t think there is one. Let’s say I hold down the control key and select some cells. It might look like this:

If I hit the BorderAround toolbar or execute selection.borderaround xlcontinuous, xlthin in the Immediate Window, Excel borders the ranges as I selected them.

What I want, of course, is to border the selection as if it’s a single area. It turned out to be a more complicated macro than I thought. I may have made it too complicated, but I’m sure you’ll tell me if that’s the case.

My plan is to use the BorderAround method, then remove the borders that I don’t want. I’ll need to cycle through the Areas and identify common borders between two areas. When I identify those borders, I’ll need a Range and which border on that range, Top, Bottom, Left, or Right. First, I create a user-defined type to store the address of the Range and which border to remove.

Type CommonBorder
    sAddress As String
    lBorderType As XlBordersIndex
End Type

Next I’ll need a function to give me the common border. I want to pass two Areas in and get a CommonBorder out.

Private Function GetCommonBorder(rOne As Range, rTwo As Range) As CommonBorder
   
    Dim sResult As String
    Dim rResult As Range
    Dim tResult As CommonBorder
   
    ‘Check top border
   If rOne.Cells(1).Row > 1 Then
        Set rResult = Intersect(rTwo, rOne.Offset(-1))
        If Not rResult Is Nothing Then
            tResult.sAddress = rResult.Address
            tResult.lBorderType = xlEdgeBottom
            GetCommonBorder = tResult
            Exit Function
        End If
    End If
   
    ‘Check bottom border
   If rOne.Cells(rOne.Cells.Count).Row < rOne.Parent.Cells.Count Then
        Set rResult = Intersect(rTwo, rOne.Offset(1))
        If Not rResult Is Nothing Then
            tResult.sAddress = rResult.Address
            tResult.lBorderType = xlEdgeTop
            GetCommonBorder = tResult
            Exit Function
        End If
    End If
   
    ‘check left border
   If rOne.Cells(1).Column > 1 Then
        Set rResult = Intersect(rTwo, rOne.Offset(, -1))
        If Not rResult Is Nothing Then
            tResult.sAddress = rResult.Address
            tResult.lBorderType = xlEdgeRight
            GetCommonBorder = tResult
            Exit Function
        End If
    End If
   
    ‘check right border
   If rOne.Cells(rOne.Cells.Count).Column < rOne.Parent.Columns.Count Then
        Set rResult = Intersect(rTwo, rOne.Offset(, 1))
        If Not rResult Is Nothing Then
            tResult.sAddress = rResult.Address
            tResult.lBorderType = xlEdgeLeft
            GetCommonBorder = tResult
            Exit Function
        End If
    End If
       
End Function

Four blocks of nearly identical code. It’s just screaming for a loop. To determine if the two Areas share a border, I extend one of the ranges in each direction and see if there’s an Intersect. For instance, to check if the bottom border is a common border, I extend rOne down one row and see if there’s an Intersect. If there is, I return the Range that results from the Intersect and xlEdgeTop to identify which border of that Range is the right one.

Note that each border is mutually exclusive. If there is a common top border, it doesn’t check for any others. Although the function doesn’t check for it, it requires that the two Areas don’t intersect each other. They can abut each other or have no common borders, but no overlapping. That’s something that really needs to be fixed.

Now that the hard part is over, I just loop through the Areas of the Selection and remove the border for any common borders.

Sub BorderAroundAll()
   
    Dim rTheRange As Range
    Dim i As Long, j As Long
    Dim tBorder As CommonBorder
   
    If TypeName(Selection) = “Range” Then
        Set rTheRange = Selection
       
        rTheRange.BorderAround xlContinuous, xlThin
       
        If rTheRange.Areas.Count > 1 Then
            For i = 1 To rTheRange.Areas.Count – 1
                For j = i + 1 To rTheRange.Areas.Count
                    tBorder = GetCommonBorder(rTheRange.Areas(i), _
                        rTheRange.Areas(j))
                       
                    If Len(tBorder.sAddress) > 0 Then
                        rTheRange.Parent.Range(tBorder.sAddress). _
                            Borders(tBorder.lBorderType).LineStyle = xlLineStyleNone
                    End If
                Next j
            Next i
        End If
       
        Set rTheRange = Nothing
    End If
   
End Sub

If tBorder.sAddress doesn’t contain anything, then there’s no common border between those two Areas. If it does, the border is removed. I get this:

Well that was fun. Two things: As I mentioned, overlapping ranges are bad. If two ranges have more than one cell in common, it doesn’t eliminate interior borders. I could just remove all borders around any intersection, but then there’s the case where the two ranges intersect AND share a common border. That leaves some unsightly holes. Since I don’t really have any use for this, I lost interest in getting it right.

Secondly, the best way to apply this type of border would be conditional formatting. I think I’d need four conditional format criteria in order to do that. In 2003, I only get three.

Posted in Uncategorized

8 thoughts on “Borders All Around

  1. using conditional formatting u’d probably only need 2 conditions, not 4; i’m thinking 1 condition for a top border and 1 condition for a left border…

  2. woops i was wrong; u’d need 3. (1) cell cell above AND cell left -> draw top and left border (2) cell cell above -> draw top border (3) cell cell left -> draw left border.

    clearly this works for certain values only; but updates live very nicely. using would have the effect of boxing values together. should be trivial to make it box values near enough (but “nearness” would not be cumulative; nearness would only be vs immediate neighbours.

  3. This does each cell in turn so could be slow for very large selections.

    Sub BorderAllAroundSelection()

        Dim rngToBorder As Range
        Dim rngCell As Range
        Dim rngTest As Range
        Dim lngBorderItem As Long
        Dim vntOffsetRows As Variant
        Dim vntOffsetCols As Variant
       
        If Not TypeName(Selection) = “Range” Then Exit Sub
       
        vntOffsetRows = Array(0, -1, 1, 0)
        vntOffsetCols = Array(-1, 0, 0, 1)
       
        Set rngToBorder = Selection
       
        On Error Resume Next
        For Each rngCell In rngToBorder
            For lngBorderItem = 0 To 3
                Set rngTest = rngCell.Offset(vntOffsetRows(lngBorderItem), vntOffsetCols(lngBorderItem))
                If Not rngTest Is Nothing Then
                    If Intersect(rngTest, rngToBorder) Is Nothing Then
                        rngCell.Borders(lngBorderItem + 7).LineStyle = xlContinuous
                    End If
                End If
            Next
        Next
       
    End Sub

  4. I was going to suggest checking the intersection of the selected range and the cell on the other side of an area’s edge, then I see that’s what Andy has done. Very elegantly as usual.

  5. i had problems with the original macro getting stuck at:

    Dim tResult As CommonBorder

    andy pope’s worked just fine… however, where in the macro is the line style stated (or, how do i change to a thicker line)

    thanks

    Mike

  6. My take would never be described as elegant, but it does have the advantage that I’ll be able to figure out how it works without having to think too much. It hurts sometimes.

    Sub bar()
    Dim r As Range
    Dim r2 As Range
    Dim btop As Boolean
    Dim bbottom As Boolean
    Dim bleft As Boolean
    Dim bright As Boolean

        on error resume next
        For Each r In Selection.Cells
            btop = True
            bbottom = True
            bleft = True
            bright = True
            For Each r2 In Selection.Cells
                If r2.Address = r.Offset(-1, 0).Address Then btop = False
                If r2.Address = r.Offset(1, 0).Address Then bbottom = False
                If r2.Address = r.Offset(0, -1).Address Then bleft = False
                If r2.Address = r.Offset(0, 1).Address Then bright = False
            Next
            If btop Then r.Borders(xlEdgeTop).LineStyle = xlContinuous
            If btop Then r.Borders(xlEdgeTop).Weight = xlThin
            If bbottom Then r.Borders(xlEdgeBottom).LineStyle = xlContinuous
            If bbottom Then r.Borders(xlEdgeBottom).Weight = xlThin
            If bright Then r.Borders(xlEdgeRight).LineStyle = xlContinuous
            If bright Then r.Borders(xlEdgeRight).Weight = xlThin
            If bleft Then r.Borders(xlEdgeLeft).LineStyle = xlContinuous
            If bleft Then r.Borders(xlEdgeLeft).Weight = xlThin
        Next
    End Sub

  7. And my approach – put borders around all areas, then remove the unnecessary ones.


    Sub test()
    Dim c As Range, s As Range
    Dim nc As Long, nr As Long

    If TypeOf Selection Is Range Then Set s = Selection _
    Else Exit Sub

    nc = s.Parent.Cells.Columns.Count
    nr = s.Parent.Cells.Rows.Count

    s.BorderAround LineStyle:=xlContinuous, Weight:=xlThin

    For Each c In s
    If c.Row > 1 Then _
    If Not Intersect(c.Offset(-1, 0), s) Is Nothing Then _
    c.Borders(xlEdgeTop).LineStyle = xlLineStyleNone

    If c.Row 1 Then _
    If Not Intersect(c.Offset(0, -1), s) Is Nothing Then _
    c.Borders(xlEdgeLeft).LineStyle = xlLineStyleNone

    If c.Column

  8. I came up with something similar to Andy. Not as well done though.

    Sub AddMultipleSelectionBorders()
        On Error Resume Next ‘In case cells have no offset cells
       Dim rCell As Range

        If Not TypeName(Selection) = “Range” Then Exit Sub

        For Each rCell In Selection
           
            If Intersect(rCell.Offset(-1), Selection) Is Nothing Then
                rCell.Borders(xlEdgeTop).LineStyle = xlContinuous
            End If
           
            If Intersect(rCell.Offset(1), Selection) Is Nothing Then
                rCell.Borders(xlEdgeBottom).LineStyle = xlContinuous
            End If
           
            If Intersect(rCell.Offset(, -1), Selection) Is Nothing Then
                rCell.Borders(xlEdgeLeft).LineStyle = xlContinuous
            End If
           
            If Intersect(rCell.Offset(, 1), Selection) Is Nothing Then
                rCell.Borders(xlEdgeRight).LineStyle = xlContinuous
            End If
       
        Next rCell

        On Error Goto 0
    End Sub


Posting code? Use <pre> tags for VBA and <code> tags for inline.

Leave a Reply

Your email address will not be published.