Sub ListAllTables()
    Dim ws As Worksheet
    Dim newSheet As Worksheet
    Dim tbl As ListObject
    Dim i As Integer

    ' Создаем новый лист
    Set newSheet = ThisWorkbook.Sheets.Add
    newSheet.Name = "TableList"

    ' Заголовки для нашего списка таблиц
    newSheet.Cells(1, 1).Value = "Table Name"
    newSheet.Cells(1, 2).Value = "Sheet Name"
    newSheet.Cells(1, 3).Value = "Table Range"

    i = 2

    ' Проходим по каждому листу и каждой таблице
    For Each ws In ThisWorkbook.Sheets
        For Each tbl In ws.ListObjects
            ' Записываем информацию о таблице в новый лист
            newSheet.Cells(i, 1).Value = tbl.Name
            newSheet.Cells(i, 2).Value = ws.Name
            newSheet.Cells(i, 3).Value = tbl.Range.Address

            i = i + 1
        Next tbl
    Next ws
End Sub