How to copy/select range of cells in a sheet that are enclosed with a border?

excel, vba

Solution

Let's say your worksheet looks like this.

Logic:

- We will find the top left cell which has the LEFT and TOP border

- Next we will find the bottom right cell which has the RIGHT and BOTTOM Border

- The logic will fail if the tables are not properly formatted or have `LEFT and TOP border` and `RIGHT and BOTTOM Border` at the wrong places.

- This is just a demonstration. If the table has data then change `What:=""` to `What:="*"`

Code: I am just demonstrating on how to search for the first table using `.Find`. To find the rest of the tables you will have to use `.Find` in a loop

Option Explicit

Sub Sample()
    Dim ws As Worksheet
    Dim TopLeftCell As Range, bottomRightCell As Range

    Set ws = ThisWorkbook.Sheets("Sheet1")

    Application.FindFormat.Clear
    With Application.FindFormat.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With

    With Application.FindFormat.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With

    Set TopLeftCell = ws.Cells.Find(What:="", LookIn:=xlValues, LookAt:= _
    xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
    , SearchFormat:=True)

    If TopLeftCell Is Nothing Then Exit Sub

    With Application.FindFormat.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Application.FindFormat.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Application.FindFormat.Borders(xlEdgeLeft)
        .LineStyle = xlNone
    End With
    With Application.FindFormat.Borders(xlEdgeTop)
        .LineStyle = xlNone
    End With

    Set bottomRightCell = ws.Cells.Find(What:="", LookIn:=xlValues, LookAt:= _
    xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
    , SearchFormat:=True)

    If bottomRightCell Is Nothing Then Exit Sub

    Debug.Print "The Table Range is " & ws.Range(TopLeftCell.Address, bottomRightCell.Address).Address
End Sub

OUTPUT

Note:

I did this exercise because I found it exciting but in real life scenario, I will never use this approach. I would use `Named Ranges` so that it is easier to work with the ranges.

EDIT

Followup from comments.

To find all the tables, use this code

Option Explicit

Dim ws As Worksheet
Dim aCell As Range
Dim bCell As String

Sub Sample()
    Dim fCell As String, lCell As String

    '~~> Change this to the relevant worksheet
    Set ws = ThisWorkbook.Sheets("Sheet4")

    Set aCell = ws.Cells(1, 1)

    fCell = FindTopLeftCell
    If fCell = "" Then Exit Sub

    lCell = FindBottomRightCell
    If lCell = "" Then Exit Sub

    bCell = fCell

    Debug.Print "The Table Range is " & ws.Range(fCell, lCell).Address

    Do
        fCell = FindTopLeftCell
        If fCell = "" Then Exit Sub

        If fCell = bCell Then Exit Sub

        lCell = FindBottomRightCell
        If lCell = "" Then Exit Sub

        Debug.Print "The Table Range is " & ws.Range(fCell, lCell).Address
    Loop
End Sub

'~~> Funciton to find the top left cell
Function FindTopLeftCell() As String
    Dim TopLeftCell As Range

    FindTopLeftCell = ""

    Application.FindFormat.Clear
    With Application.FindFormat.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With

    With Application.FindFormat.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With

    Set TopLeftCell = ws.Cells.Find(What:="*", After:=aCell, LookIn:=xlValues, LookAt:= _
    xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
    , SearchFormat:=True)

    If Not TopLeftCell Is Nothing Then FindTopLeftCell = TopLeftCell.Address
End Function

'~~> Funciton to find the bottom right cell
Function FindBottomRightCell() As String
    Dim bottomRightCell As Range

    FindBottomRightCell = ""

    Application.FindFormat.Clear
    With Application.FindFormat.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Application.FindFormat.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Application.FindFormat.Borders(xlEdgeLeft)
        .LineStyle = xlNone
    End With
    With Application.FindFormat.Borders(xlEdgeTop)
        .LineStyle = xlNone
    End With

    Set bottomRightCell = ws.Cells.Find(What:="*", After:=aCell, LookIn:=xlValues, LookAt:= _
    xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
    , SearchFormat:=True)

    If Not bottomRightCell Is Nothing Then FindBottomRightCell = bottomRightCell.Address

    Set aCell = bottomRightCell
End Function

Output

Problem

Original source