VBA TIPS
Finding the range with borders

When you have many tables in each worksheet and have to change the appearance of the tables at once, it would take time very much, wouldn't it? In that case, Looping really helps. Here is a sample for finding the range with border.

As the sample, this page contains 4 procedure (3 Subs and 1 UDF)

  • Sub MakeinsWksForTest()
  • Sub Test1()
  • Sub Test2()
  • Function GetBorderRange(sh As String) As Range


Sub MakeinsWksForTest would make 20 workseets for testing the UDF named GetBorderRange. When 20 worksheets are made, you will see the following message in the worksheet 1.



In each worksheet, a table with border has been made by this program as follows.



Then please run Test1 for changing the weight of the borders, Test2 is for changing interior color of each table. Both of testing programs would work depending on the range that the function named GetBorderRange returned.



Place the following in the standard module.

Option Explicit

Sub MakeinsWksForTest()
    Dim ws As Worksheet
    Dim i As Integer
    Dim j As Integer
    Dim intSt As Integer     'For Start Range
    Dim intRnd As Integer    'For make tables as ran

    '// Delete unnecessary worksheets.
    Application.DisplayAlerts = False
    For Each ws In Worksheets
        If ws.Index <> 1 Then
            ws.Delete
        Else
            ws.Cells.Clear
            With ws.[A1]
                .Value = "This program generated a table with border " & _
                "of each worksheet as per the samples. " & _
                "Have a look at other worksheets"
            End With
        End If
    Next
    Application.DisplayAlerts = True

    '// Make worksheets for test
    For i = 1 To 20
        Sheets.Add after:=Sheets(Sheets.Count)
        Randomize
        intSt = Int((5 * Rnd) + 1)
        Randomize
        intRnd = Int((10 * Rnd) + 2)
        With Cells(intSt, intSt).Resize(intRnd, intRnd)
            .Borders(xlDiagonalDown).LineStyle = xlNone
            .Borders(xlDiagonalUp).LineStyle = xlNone
            For j = 7 To 12
                With .Borders(j)
                    .LineStyle = xlContinuous
                    .Weight = xlThin
                End With
            Next
        End With
    Next
    Application.Goto Sheets(1).[A1]
End Sub

Sub Test1()
    Dim rngBorder As Range
    Dim ws As Worksheet
    For Each ws In Worksheets
        Set rngBorder = GetBorderRange(ws.Name)
        If Not rngBorder Is Nothing Then
        rngBorder.BorderAround Weight:=xlMedium
        End If
    Next
    MsgBox "...Done!"
End Sub

Sub Test2()
    Dim rngBorder As Range
    Dim ws As Worksheet
    For Each ws In Worksheets
        Set rngBorder = GetBorderRange(ws.Name)
        If Not rngBorder Is Nothing Then
        With rngBorder.Interior
            .ColorIndex = 36
            .Pattern = xlSolid
        End With
        End If
    Next
End Sub

Function GetBorderRange(sh As StringAs Range
    Dim r As Integer, c As Integer
    Dim St As Range, En As Range, flg As Integer
    On Error Resume Next
    With Worksheets(sh).UsedRange
        For c = 1 To .Columns.Count + 1
            For r = 1 To .Rows.Count + 1
                If flg = 0 And .Cells(r, c).Borders(7).LineStyle <> xlNone Then
                    Set St = .Cells(r, c): flg = 1
                End If
                If flg = 1 And .Cells(r, c).Borders(7).LineStyle = xlNone Then
                    Set En = .Cells(r, c).Offset(-1)
                    flg = 2
                    Exit For
                End If
            Next
            If flg = 2 Then
                Set GetBorderRange = Range(St, En)
                Exit For
            End If
        Next
        For c = 0 To .Columns.Count + 1
            If En.Offset(, c).Borders(7).LineStyle = xlNone Then
                Set En = En.Offset(, c - 2)
                Exit For
            End If
        Next
    End With
    Set GetBorderRange = Range(St, En)
End Function



| HOME |
Copyright © cellmasters.net - colo's junk room All Right Reserved
ABOUT
WORKS
THE CELL MASTERS
CONTACT
LINKS
Tips and Information about Microsoft Excel|Masaru Kaji aka Colo