VBA for adding borders to a range based on condition?

**antonymiller** · 07-12-2009, 05:18 AM

I have a spread sheet I use to track tools. One tool may be checked out / returned several times a week. When I do custom sorting I end up with the Tools listed neatly by date and number. EX:

A1 b1
7/11/09 Tool1
7/12/09 Tool 1

7/11/09 Tool3
7/12/09 Tool3 etc.

I have a macro that inserts a blank row between dissimilar tool numbers. What I'd like to add is another macro that adds a box border around the range of cells for each particular tool. So that it looks something like this.

___________________________________________________________

7/11/09 Tool1
7/12/09 Tool 1
___________________________________________________________

___________________________________________________________
7/11/09 Tool3
7/12/09 Tool3 etc.
___________________________________________________________

The problem I'm having is that each time I add a new row to a particular tool number - I have to go in and manually adjust the border. I don't know enough to account for an unspecified range of cells - I never know how many times a tool will be used - or consequently how many cells the box border wit will need to go around.

Any help would be appreciated.

**Krishnakumar** · 07-12-2009, 06:43 AM

Hi,

Sub kTest()
Dim Rng As Range, aRng As Range

On Error Resume Next
Set Rng = ActiveSheet.Range("a:b").SpecialCells(xlCellTypeConstants)
On Error GoTo 0

If Not Rng Is Nothing Then
    For Each aRng In Rng.Areas
        CreateBorder aRng
    Next
End If
End Sub
Sub CreateBorder(ByRef r As Range)
With r
    .Borders(xlDiagonalDown).LineStyle = xlNone
    .Borders(xlDiagonalUp).LineStyle = xlNone
    .Borders(xlEdgeLeft).LineStyle = xlNone
    .Borders(xlEdgeTop).LineStyle = xlNone
    .Borders(xlEdgeBottom).LineStyle = xlNone
    .Borders(xlEdgeRight).LineStyle = xlNone
    .Borders(xlInsideVertical).LineStyle = xlNone
    .Borders(xlInsideHorizontal).LineStyle = xlNone
    .Borders(xlDiagonalDown).LineStyle = xlNone
    .Borders(xlDiagonalUp).LineStyle = xlNone
    .Borders(xlEdgeLeft).LineStyle = xlNone
    With .Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With .Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    .Borders(xlEdgeRight).LineStyle = xlNone
    .Borders(xlInsideVertical).LineStyle = xlNone
    .Borders(xlInsideHorizontal).LineStyle = xlNone
End With
End Sub

Adjust the range

HTH

**antonymiller** · 07-12-2009, 04:16 PM

Hi Krish -

Thanks a lot, this is way simpler than the approach i was trying to take. I failed to represent in my original post that there is a empty row between each data entry.

___________________________________________________________

7/11/09 Tool1
EMPTY ROW
7/12/09 Tool 1
___________________________________________________________

___________________________________________________________
7/11/09 Tool3
EMPTY ROW
7/12/09 Tool3 etc.
___________________________________________________________

How can account for these empty rows between tool entries and still manage to get the borders around the range of cells for that particular tool?

Thanks

**Krishnakumar** · 07-12-2009, 10:24 PM

Still not sure about your layout. Post an attachment here.

Kris

**antonymiller** · 07-12-2009, 10:48 PM

Hi Kris,

Here is the attachment- it pretty much outlines what I'm shooting for.
Mainly just need to figure out how to get the borders to appear around the perimeter of the first and last row a particular tool number appears in.... the blank rows in between shouldn't have a top or bottom border.

Thanks again.

**Krishnakumar** · 07-13-2009, 02:19 PM

Hi,

There may be better solution...

Sub kTest()
Dim a, i As Long, v, x, y

With ActiveSheet
    a = .Range("b3:b" & .Range("b" & Rows.Count).End(xlUp).Row)
End With
v = UNIQUE(a)
For i = 1 To UBound(a, 1)
    If Not IsEmpty(a(i, 1)) Then
        y = Application.Match(a(i, 1), Application.Index(v, 0, 1), 0)
        x = Application.Index(v, y, 2)
        CreateBorder Cells(i + 2, "a").Resize(x * 2 - 2 + 1, 13)
        i = i + (x * 2 - 2 + 1)
    End If
Next
End Sub
Function UNIQUE(v)
Dim i, w(), n As Long, r()
ReDim w(1 To UBound(v, 1), 1 To 2)
With CreateObject("scripting.dictionary")
    .comparemode = 1
    For Each i In v
        If Not IsEmpty(i) Then
            If Not .exists(i) Then
                n = n + 1: w(n, 1) = i: w(n, 2) = 1
                .Add i, Array(n, 2)
            Else
                r = .Item(i)
                w(r(0), 2) = w(r(0), 2) + 1
                .Item(i) = r
            End If
        End If
    Next
End With
If n > 0 Then UNIQUE = w
End Function
Sub CreateBorder(ByRef r As Range)
With r
    .Borders(xlDiagonalDown).LineStyle = xlNone
    .Borders(xlDiagonalUp).LineStyle = xlNone
    .Borders(xlEdgeLeft).LineStyle = xlNone
    .Borders(xlEdgeTop).LineStyle = xlNone
    .Borders(xlEdgeBottom).LineStyle = xlNone
    .Borders(xlEdgeRight).LineStyle = xlNone
    .Borders(xlInsideVertical).LineStyle = xlNone
    .Borders(xlInsideHorizontal).LineStyle = xlNone
    .Borders(xlDiagonalDown).LineStyle = xlNone
    .Borders(xlDiagonalUp).LineStyle = xlNone
    .Borders(xlEdgeLeft).LineStyle = xlNone
    With .Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With .Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    .Borders(xlEdgeRight).LineStyle = xlContinuous
    .Borders(xlEdgeLeft).LineStyle = xlContinuous
    .Borders(xlInsideVertical).LineStyle = xlNone
    .Borders(xlInsideHorizontal).LineStyle = xlNone
End With
End Sub

HTH