Locating all the tables on one spreadsheet using Excel VBA - excel

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