Locating all the tables on one spreadsheet using Excel VBA

Question

I have a few spreadsheets with various tables in different formats. My task is to locate and identify anything on the spreadsheets that can be considered a table, and flatten it into a text file. Currently I am only looking for a solution to locate all tables on one spreadsheet.

The rules are:

• Spreadsheet format is somewhat fixed, I have to process what I am given.
• A completely empty line can split a table into two, unless there's a sure way to tell what is a missing line within one table and what is an actual new table.
• I can handle merged fields beforehand if needs be (split them and backfill with the common value, that's already written and is working)
• The tables could have a different number of columns, different header rows, and they could begin in any column.
• I consider records in the same line to be part of the same table, I am not expecting to find tables next to one another.

The code I have so far as follows:

Sub Find_All_Tables()
'Finds all the separate tables in the worksheet

Dim rStart As Range, rFoundStart As Range, rFoundEnd As Range
Dim lRow As Long, lCol As Long

   lRow = Cells.Find(What:="*", _
                   After:=Range("A1"), _
                   LookAt:=xlPart, _
                   LookIn:=xlFormulas, _
                   SearchOrder:=xlByRows, _
                   SearchDirection:=xlPrevious, _
                   MatchCase:=False).Row
   
   lCol = Cells.Find(What:="*", _
                   After:=Range("A1"), _
                   LookAt:=xlPart, _
                   LookIn:=xlFormulas, _
                   SearchOrder:=xlByColumns, _
                   SearchDirection:=xlPrevious, _
                   MatchCase:=False).Column
   
   MsgBox "Last non-empty cell on the spreadsheet is " & Cells(lRow, lCol).Address

   Set rStart = Range("A1")
   
   MsgBox rStart.Row

   While rStart.Row < lRow

   On Error Resume Next
   Set rFoundStart = Cells.Find(What:="*", _
                   After:=rStart, _
                   LookAt:=xlPart, _
                   LookIn:=xlFormulas, _
                   SearchOrder:=xlByRows, _
                   SearchDirection:=xlNext, _
                   MatchCase:=False)
   
   On Error GoTo 0
   
   If rFoundStart Is Nothing Then
       MsgBox "All cells are blank."
   Else
       rFoundStart.End(xlToRight).End(xlDown).Select
       Set rFoundEnd = Selection
       'MsgBox "First Cell: " & rFoundStart.Address
       'MsgBox "Last Cell: " & ActiveCell.Address
       Range(rFoundStart.Address, rFoundEnd.Address).Select
       MsgBox "There is a table between " & rFoundStart.Address & " and " & rFoundEnd.Address
   End If
   
   Set rStart = Range("A" & rFoundEnd.Row + 1)
   
   Wend
   
End Sub

The sample sheet I am looking at is as messy as possible to account for "creative" formatting.

The error I'm getting is due to the fact that the second table starts from B7 and ends in E1048576, which is well past the loop condition - I would like this range to end in E8 (or E9 if possible or once the merged cells are broken up).

Answer 1

I've got this code from way back when.... 2008.
No idea if it works with ListObject tables.

Original MrExcel post: Find all lists in a workbook

Sub Test()
    Dim aLists  As Variant
    Dim aLists1 As Variant
    '//Find lists in a different workbook.
''    aLists = FindRegionsInWorkbook(Workbooks("Test Workbook.xls"))
    '//Find lists in the this workbook.
    aLists1 = FindRegionsInWorkbook(ThisWorkbook)
    Debug.Assert False
End Sub


'//Returns each region in each worksheet within the workbook in the 'sRegion' variable.
'//
'//Written by Zack Barresse (MVP), Oregon, USA.
'//
'//http://www.mrexcel.com/forum/showthread.php?t=309052

Public Function FindRegionsInWorkbook(wrkBk As Workbook) As Variant
    Dim ws As Worksheet, rRegion As Range, sRegion As String, sCheck As String
    Dim sAddys As String, arrAddys() As String, aRegions() As Variant
    Dim iCnt As Long, i As Long, j As Long
    '//Cycle through each worksheet in workbook.
    j = 0
    For Each ws In wrkBk.Worksheets
        sAddys = vbNullString
        sRegion = vbNullString
        On Error Resume Next
        '//Find all ranges of constant & formula valies in worksheet.
        sAddys = ws.Cells.SpecialCells(xlCellTypeConstants, 23).Address(0, 0) & ","
        sAddys = sAddys & ws.Cells.SpecialCells(xlCellTypeFormulas, 23).Address(0, 0)
        If Right(sAddys, 1) = "," Then sAddys = Left(sAddys, Len(sAddys) - 1)
        On Error GoTo 0
        If sAddys = vbNullString Then GoTo SkipWs
        '//Put each seperate range into an array.
        If InStr(1, sAddys, ",") = 0 Then
            ReDim arrAddys(1 To 1, 1 To 2)
            arrAddys(1, 1) = ws.Name
            arrAddys(1, 2) = sAddys
        Else
            arrAddys = Split(sAddys, ",")
            For i = LBound(arrAddys) To UBound(arrAddys)
                arrAddys(i) = "'" & ws.Name & "'!" & arrAddys(i)
            Next i
        End If
        '//Place region that range sits in into sRegion (if not already in there).
        For i = LBound(arrAddys) To UBound(arrAddys)
            If InStr(1, sRegion, ws.Range(arrAddys(i)).CurrentRegion.Address(0, 0)) = 0 Then
                sRegion = sRegion & ws.Range(arrAddys(i)).CurrentRegion.Address(0, 0) & "," '*** no sheet
                sCheck = Right(arrAddys(i), Len(arrAddys(i)) - InStr(1, arrAddys(i), "!"))
                ReDim Preserve aRegions(0 To j)
                aRegions(j) = Left(arrAddys(i), InStr(1, arrAddys(i), "!") - 1) & "!" & ws.Range(sCheck).CurrentRegion.Address(0, 0)
                j = j + 1
            End If
        Next i
SkipWs:
    Next ws
    On Error GoTo ErrHandle
    FindRegionsInWorkbook = aRegions
    Exit Function
ErrHandle:
    'things you might want done if no lists were found...
End Function