Format Cells between empty rows until there is no more data

Hi and welcome to the forums,

try this:

Option Explicit

Sub test()
    Dim xlRng As Range
    Dim aBorders: aBorders = Array(xlMedium, xlMedium, xlMedium, xlMedium, xlThin, xlThin)
    Dim sAddr As String
    Dim i As Byte
    On Error GoTo ErrorHandler
    Application.ScreenUpdating = False
    With Worksheets("Start")
        Set xlRng = .Columns(1).Find(What:="*", After:=.Cells(.Rows.Count, 1), LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
        If Not xlRng Is Nothing Then
            sAddr = xlRng.Address
            Do
                With xlRng.CurrentRegion
                    .WrapText = True
                    .Borders(xlDiagonalDown).LineStyle = xlNone
                    .Borders(xlDiagonalUp).LineStyle = xlNone
                    For i = 7 To 12
                        With .Borders(i)
                            .LineStyle = xlContinuous
                            .ColorIndex = xlAutomatic
                            .TintAndShade = 0
                            .Weight = aBorders(i - 7)
                        End With
                    Next i
                End With
                Set xlRng = .Columns(1).Find(What:=vbNullString, After:=xlRng, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
                xlRng.RowHeight = 10
                Set xlRng = .Columns(1).Find(What:="*", After:=xlRng, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
            Loop While Not xlRng Is Nothing And xlRng.Address <> sAddr And xlRng.Row <> 1
        End If
    End With
    
Proc_Exit:
    Application.ScreenUpdating = True
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & ": " & Err.Description, vbCritical + vbOKOnly, "Error"
    Resume Proc_Exit
End Sub

I put your code at the end of what I am using and I get this error:
Compile error:
Duplicate declaration in current scope.

The "i As Byte" in the "Dim i As Byte" line is highlighted.

I have this code above what you have.

    Dim r As Long, mcol As String, i As Long
    ' find last used cell in Column B
    r = Cells(Rows.Count, "B").End(xlUp).Row
    ' get value of  last used cell in column B
    mcol = Cells(r, 2).Value
    ' insert rows by looping from bottom
    For i = r To 2 Step -1
    If Cells(i, 2).Value <> mcol Then
    mcol = Cells(i, 2).Value
    Rows(i + 1).Insert
    End If
    Next i

Hi,

The code is not intended to be pasted below other code, especially when you don't know whats happening there, use it as a separate sub by calling it at the end of your main procedure.

Hi,

I assume its in the following line caused by a missing worksheet called "Start"

With Worksheets("Start")

Can the sheetname change or is it every time the same you run the code on?

Hi,
try

Option Explicit

Sub test()
    Dim xlRng As Range
    Dim aBorders: aBorders = Array(xlMedium, xlMedium, xlMedium, xlMedium, xlThin, xlThin)
    Dim sAddr As String
    Dim i As Byte
    Dim lngMaxRows As Long
    
    On Error GoTo ErrorHandler
    Application.ScreenUpdating = False
    
    With Worksheets("Start")
        lngMaxRows = .Cells(1, 1).CurrentRegion.Columns.Count
        
        Set xlRng = .Columns(1).Find(What:="*", After:=.Cells(.Rows.Count, 1), LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
        If Not xlRng Is Nothing Then
            sAddr = xlRng.Address
            Do
                With xlRng.CurrentRegion
                    .Select
                    Set xlRng = .Resize(, lngMaxRows - .Columns.Count + .Columns.Count)
                End With
                With xlRng
                    .Select
                    .WrapText = True
                    .Borders(xlDiagonalDown).LineStyle = xlNone
                    .Borders(xlDiagonalUp).LineStyle = xlNone
                    For i = 7 To 12
                        With .Borders(i)
                            .LineStyle = xlContinuous
                            .ColorIndex = xlAutomatic
                            .TintAndShade = 0
                            .Weight = aBorders(i - 7)
                        End With
                    Next i
                End With
                Set xlRng = .Columns(1).Find(What:=vbNullString, After:=xlRng.Cells(1, 1), LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
                xlRng.RowHeight = 10
                Set xlRng = .Columns(1).Find(What:="*", After:=xlRng.Cells(1, 1), LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
            Loop While Not xlRng Is Nothing And xlRng.Address <> sAddr And xlRng.Row <> 1
        End If
    End With
    
Proc_Exit:
    Application.ScreenUpdating = True
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & ": " & Err.Description, vbCritical + vbOKOnly, "Error"
    Resume Proc_Exit
End Sub

What I did:
Instead of using the "currentregion" of a cell I check the max number of columns in row 1 first to determine how many columns should be "bordered"

Based on your last post in this thread, its apparent that you are satisfied with the solution(s) you've received and have solved your question, but you haven't marked your thread as "SOLVED". I will do it for you this time.

In future, to mark your thread as Solved, you can do the following -
Select Thread Tools-> Mark thread as Solved.

Incase your issue is not solved, you can undo it as follows -
Select Thread Tools-> Mark thread as Unsolved.

Also, since you are relatively new to the forum, i would like to inform you that you can thank those who have helped you by clicking the small star icon located in the lower left corner of the post which helped you. This adds to the reputation of the person who has taken the time to help you.