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.
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.
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.
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.
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…
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.
This does each cell in turn so could be slow for very large selections.
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
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.
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
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.
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
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
I came up with something similar to Andy. Not as well done though.
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