Copy a range of cells above / below the last one with a border

[OfficeUser]

I have a spreadsheet which has a border on the bottom of cells in row 32-37 (only one of those rows has this). I want to copy all the cells above this.

For example, Row 37 has a border on the bottom of the cells, I want to then copy range A4:M36.

The same goes for the range below that border, I want to then copy range A38:M62. Is this something that is able to be done? Thanks!!

 

[JackDanIce]

Where do you want to copy those ranges to?

 

[OfficeUser]

Where do you want to copy those ranges to?

Lets say Sheet2 starting in Range A1 for anything above the border. And Sheet3 starting in Range A1 for anything below the border.

 

[JackDanIce]

Try:

Sub Underlineborder()

    Dim x       As Long
    Dim LR      As Long
    Dim arrT()  As Variant
    Dim arrB()  As Variant
    
    With Sheets("Sheet1")
        LR = .Cells(.Rows.count, 1).End(xlUp).row
    
        For x = 32 To 37
            If .Cells(x, 1).Borders(xlEdgeBottom).LineStyle <> xlLineStyleNone Then Exit For
        Next x
    
        arrT = .Cells(4, 1).Resize(x - 4, 13).Value
        arrB = .Cells(x + 1, 1).Resize(LR - x, 13).Value
    End With
    
    Sheets("Sheet2").Cells(1, 1).Resize(UBound(arrT, 1), UBound(arrT, 2)).Value = arrT
    Sheets("Sheet3").Cells(1, 1).Resize(UBound(arrB, 1), UBound(arrB, 2)).Value = arrB
    
    Erase arrT
    Erase arrB

End Sub

 

[OfficeUser]

Try:

Sub Underlineborder()

    Dim x       As Long
    Dim LR      As Long
    Dim arrT()  As Variant
    Dim arrB()  As Variant
    
    With Sheets("Sheet1")
        LR = .Cells(.Rows.count, 1).End(xlUp).row
    
        For x = 32 To 37
            If .Cells(x, 1).Borders(xlEdgeBottom).LineStyle <> xlLineStyleNone Then Exit For
        Next x
    
        arrT = .Cells(4, 1).Resize(x - 4, 13).Value
        arrB = .Cells(x + 1, 1).Resize(LR - x, 13).Value
    End With
    
    Sheets("Sheet2").Cells(1, 1).Resize(UBound(arrT, 1), UBound(arrT, 2)).Value = arrT
    Sheets("Sheet3").Cells(1, 1).Resize(UBound(arrB, 1), UBound(arrB, 2)).Value = arrB
    
    Erase arrT
    Erase arrB

End Sub

The one thing it does is not copy the row if the border is on the bottom of the row. For example, if Row 32 has a bottom border, it will only copy to Row 31. I explained it incorrectly, otherwise it works great, I appreciate it!!!

 

[JackDanIce]

Try:

Sub Underlineborder()

    Dim x       As Long
    Dim LR      As Long
    Dim arrT()  As Variant
    Dim arrB()  As Variant
        
    With Sheets("Sheet1")
        LR = .Cells(.Rows.count, 1).End(xlUp).row
        .Cells(4, 15).Resize(LR, 13).ClearContents
        For x = 32 To 37
            If .Cells(x, 1).Borders(xlEdgeBottom).LineStyle <> xlLineStyleNone Then Exit For
        Next x
        
        arrT = .Cells(4, 1).Resize(x - 3, 13).Value
        arrB = .Cells(x + 1, 1).Resize(LR - x, 13).Value
    End With
    
    Sheets("Sheet2").Cells(1, 1).Resize(UBound(arrT, 1), UBound(arrT, 2)).Value = arrT
    Sheets("Sheet3").Cells(1, 1).Resize(UBound(arrB, 1), UBound(arrB, 2)).Value = arrB

    Erase arrT
    Erase arrB

End Sub

 

[OfficeUser]

It works great!! Something as simple as this will save about 4 hrs. per week. Thanks again!!

 

[JackDanIce]

You're welcome!