CODEWITHSUNDEEP
vbaloopsexcelborder
James
James

Reputation: 499

Apply borders in a used cell Range VBA

I am trying to apply a border around a group of used cells dynamically. The column Range is (B7:E7) The number of rows will always vary, so the code needs to be dynamic. My code below is not achieving this:

Sub Borders()

Application.ScreenUpdating = False
Dim lngLstCol As Long, lngLstRow As Long

lngLstRow = ActiveSheet.UsedRange.Rows.Count
lngLstCol = ActiveSheet.UsedRange.Columns.Count

For Each rngCell In Range("B7:B" & lngLstRow)
    If rngCell.Value > "" Then
        r = rngCell.row
        c = rngCell.Column
        Range(Cells(r, c), Cells(r, lngLstCol)).Select
            With Selection.Borders
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
    End If
Next

Application.ScreenUpdating = True

End Sub

Upvotes: 2

Views: 24098

Answers (2)

kitap mitap
kitap mitap

Reputation: 709

This code puts borders around all non-empty cells beyond B7.

Sub Borders()

    Application.ScreenUpdating = False

    Dim lngLstCol As Long, lngLstRow As Long

    lngLstRow = ActiveSheet.UsedRange.Rows.Count
    lngLstCol = ActiveSheet.UsedRange.Columns.Count

    For Each rngCell In Range(Range("B7"), Cells(lngLstRow, lngLstCol))
        If rngCell.Value > "" Then
            rngCell.Select 'Select cells
            With Selection.Borders
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
        End If
    Next

    Application.ScreenUpdating = True

End Sub

The code below puts borders around the used range beyond B7:

Sub BordersB()

    Application.ScreenUpdating = False

    Dim lngLstCol As Long, lngLstRow As Long

    lngLstRow = ActiveSheet.UsedRange.Rows.Count
    lngLstCol = ActiveSheet.UsedRange.Columns.Count

    With Range(Range("B7"), Cells(lngLstRow, 2)).Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With

    With Range(Range("B7"), Cells(7, lngLstCol)).Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With

    With Range(Cells(7, lngLstCol), Cells(lngLstRow, lngLstCol)).Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With

    With Range(Cells(lngLstRow, 2), Cells(lngLstRow, lngLstCol)).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With

    Application.ScreenUpdating = True

End Sub

Upvotes: 3

Davesexcel
Davesexcel

Reputation: 6984

This will add borders to all none blank cells below row 6 in Columns(B:C)

    Sub AddBorders()
    Dim Rws As Long, Rng As Range, c As Range

    Rws = Range("A1").SpecialCells(xlCellTypeLastCell).Row
    Set Rng = Range(Cells(7, "B"), Cells(Rws, "C"))

    For Each c In Rng.Cells

        If c <> "" Then

            With c.Borders

                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic

            End With

        End If

    Next c

End Sub

Upvotes: 1

Related Questions