Option Explicit 
 
Sub RestoreTables() 
    Dim i As Long 
    Dim ws As Worksheet 
    Dim X() As Variant, RegEx As Object, RegM 
    Dim FirstCell As Range 
    Dim Myrange As Range, Newrange As Range, CurrRange As Range 
    Dim TestRange As Range, nArea As Range 
     
    Application.ScreenUpdating = False 
    On Error Resume Next 
    Set ws = ActiveWorkbook.Sheets("DataTableMap") 
    Set CurrRange = Selection 
    If CurrRange Is Nothing Then Set CurrRange = ActiveSheet.Range("a1") 
    On Error GoTo 0 
     
    If ws Is Nothing Then Exit Sub 
    Set RegEx = CreateObject("vbscript.regexp") 
    RegEx.Pattern = "=TABLE\((.+)?,(.+)?\)" 
     
    ws.Activate 
    If Application.CountA(Range("a1:a65536")) = 0 Then 
        MsgBox "No tables to restore!" 
        Exit Sub 
    End If 
    Set Myrange = Range([a1], [a1].End(xlDown)) 
    Set Myrange = Myrange.Resize(Myrange.Rows.Count, 3) 
    X = Myrange 
     
    Set Newrange = Range(X(1, 2)) 
    For i = 1 To UBound(X, 1) 
         ' Check for a change in the Table formula to mark the end of a table
         'If i < UBound(X, 1) Then Set TestRange = Union(Newrange, Range(X(i + 1, 2)))
         
        If Newrange.Cells.Count = 1 Then Set FirstCell = Newrange 
         
        If i = UBound(X, 1) Then GoTo FinishUp 
         
        If X(Application.Min(i + 1, UBound(X, 1)), 1) = X(i, 1) And i <> UBound(X, 1) And ((Range(X(i + 1, 2)).Row = Range(X(i, 2)).Row And Range(X(i + 1, 2)).Column - Range(X(i, 2)).Column = 1) Or _ 
        (Range(X(i + 1, 2)).Column = FirstCell.Column <= 1 And Range(X(i + 1, 2)).Row - Range(X(i, 2)).Row <= 1)) Then 
             
             
             'Look for table change
            Set Newrange = Union(Newrange, Application.Range(CStr(X(i + 1, 2)))) 
        Else 
FinishUp: 
             
            For Each nArea In Newrange.Areas 
                 ' a little ugly. Handles two data tables that occur in the same row,
                 ' and also share an identical table lookup
                Set Newrange = nArea 
                 
                 ' Parse the table formula to test for a two way or one way column/row table
                Set RegM = RegEx.Execute(X(i, 1)) 
                If RegM(0).submatches(0) <> "" And RegM(0).submatches(1) <> "" Then 
                     'Code to remap a two way table
                    Set Myrange = Range(Newrange.Address).Offset(-1, -1).Resize(Range(Newrange.Address).Rows.Count + 1, Range(Newrange.Address).Columns.Count + 1) 
                    Sheets(X(i, 3)).Activate 
                    ActiveSheet.Range(Myrange.Address).Table RowInput:=Range(RegM(0).submatches(0)), ColumnInput:=Range(RegM(0).submatches(1)) 
                     
                ElseIf RegM(0).submatches(0) <> "" Then 
                     'Code to remap for a row table
                    Set Myrange = Range(Newrange.Address).Offset(-1, -1).Resize(Range(Newrange.Address).Rows.Count + 1, Range(Newrange.Address).Columns.Count + 1) 
                    Sheets(X(i, 3)).Activate 
                    ActiveSheet.Range(Myrange.Address).Table RowInput:=Range(RegM(0).submatches(0)) 
                Else 
                     'Code to remap a column table
                    Set Myrange = Range(Newrange.Address).Offset(-1, -1).Resize(Range(Newrange.Address).Rows.Count + 1, Range(Newrange.Address).Columns.Count + 1) 
                    Sheets(X(i, 3)).Activate 
                    ActiveSheet.Range(Myrange.Address).Table ColumnInput:=Range(RegM(0).submatches(1)) 
                End If 
            Next 
            If i < UBound(X, 1) Then Set Newrange = Range(X(i + 1, 2)) 
        End If 
    Next 
     
     'clear map
     'ws.Cells.Clear
     
     'goto starting cell
    Application.GoTo reference:=CurrRange 
     
     'refresh results
    Application.Calculate 
     
    Set Myrange = Nothing 
    Set Newrange = Nothing 
    Set TestRange = Nothing 
    Set CurrRange = Nothing 
    Set ws = Nothing 
    Set RegM = Nothing 
    Set RegEx = Nothing 
     
    Application.ScreenUpdating = True 
End Sub 
 
Sub MapDataTables() 
    Dim ws As Worksheet, newWs As Worksheet 
    Dim C As Range, CurrRange As Range 
    Dim SearchString As String, FirstAddress As String 
    Dim i As Long, DelCheck As Long 
    Dim X(1 To 65536, 1 To 4) 
     
     
    Application.ScreenUpdating = False 
    On Error Resume Next 
    Set newWs = ActiveWorkbook.Sheets("DataTableMap") 
    Set CurrRange = Selection 
    If CurrRange Is Nothing Then Set CurrRange = ActiveSheet.Range("a1") 
    On Error GoTo 0 
     ' Add the very hidden sheet "DataTableMap" if it doesn't already exist
    If newWs Is Nothing Then 
        Set newWs = ActiveWorkbook.Worksheets.Add 
        newWs.Visible = xlVeryHidden 
        newWs.Name = "DataTableMap" 
    Else 
         ' If the storage area is not blank then flag a warning that previous data will be overwritten
        If Application.CountA(newWs.Cells) > 0 Then 
            DelCheck = MsgBox("Data that was mapped at " & newWs.Range("E1") & " already exists" & vbNewLine & _ 
            "If you proceed then this previously mapped data will be lost forever" & vbNewLine & vbNewLine & _ 
            "Do you want to proceed with mapping any current data tables (these will be stored) and remove the previous map?", vbYesNo + vbCritical, "Warning") 
            If DelCheck <> vbYes Then Exit Sub 
            newWs.Cells.Clear 
        End If 
    End If 
     ' Look for "=TABLE(" in cell formulas
    SearchString = "=TABLE(" 
    For Each ws In ActiveWorkbook.Worksheets 
         ' Dump any complying cells to the mapping sheet
        If ws.Name <> "DataTableMap" Then 
            Set C = ws.Cells.Find(SearchString, [a1], xlFormulas, xlPart, xlByRows) 
            If Not C Is Nothing Then 
                i = i + 1 
                FirstAddress = C.Address 
                X(i, 1) = "'" & C.Formula 
                X(i, 2) = C.Address 
                X(i, 3) = ws.Name 
                X(i, 4) = C.Row 
                Do 
                    Set C = ws.Cells.FindNext(C) 
                    i = i + 1 
                    X(i, 1) = "'" & C.Formula 
                    X(i, 2) = C.Address 
                    X(i, 3) = ws.Name 
                    X(i, 4) = C.Row 
                Loop While C.Address <> FirstAddress 
                 'clean up duplicate row at end
                i = i - 1 
            Else 
            End If 
        End If 
    Next 
    i = i + 1 
    newWs.Activate 
    newWs.Range("A:D") = X 
    newWs.Rows(i).EntireRow.Delete 
     ' Sort the data by table formula and table row to group like tables together
    newWs.Range("A:D").Sort Key1:=Range("A1"), Order1:=xlAscending, Key2:=Range("D1") _ 
    , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1 
     
    If Application.CountA(Range("a1:a65536")) <> 0 Then 
        Call ClearTables 
    Else 
        MsgBox "No tables found!" 
    End If 
    Application.GoTo reference:=CurrRange 
     
    Set C = Nothing 
    Set newWs = Nothing 
    Set CurrRange = Nothing 
     
    Application.ScreenUpdating = True 
End Sub 
 
Private Sub ClearTables() 
    Dim i As Long 
    Dim ws As Worksheet 
    Dim X() As Variant 
    Dim Myrange As Range, Newrange As Range 
     
    On Error Resume Next 
    Set ws = ActiveWorkbook.Sheets("DataTableMap") 
    On Error GoTo 0 
     
    If ws Is Nothing Then Exit Sub 
     
    ws.Activate 
     
    Set Myrange = Range([a1], [a1].End(xlDown)) 
    Set Myrange = Myrange.Resize(Myrange.Rows.Count, 3) 
    X = Myrange 
     
    Set Newrange = Range(X(1, 2)) 
    For i = 1 To UBound(X, 1) 
         ' Look through the found cells containing the "=TABLE(" string in the formula.
         ' If the cell is part of a table then add it to a range union
        If X(Application.Min(i + 1, UBound(X, 1)), 1) = X(i, 1) And Range(X(Application.Min(i + 1, UBound(X, 1)), 2)).Row - Range(X(i, 2)).Row <= 1 And i <> UBound(X, 1) Then 
            Set Newrange = Union(Newrange, Range(X(i + 1, 2))) 
        Else 
             ' The end of a table has been found. Clear the entire table range
            Sheets(X(i, 3)).Activate 
            ActiveSheet.Range(Newrange.Address).ClearContents 
            If i < UBound(X, 1) Then Set Newrange = Range(X(i + 1, 2)) 
        End If 
    Next 
    ws.Range("e1") = Now() 
    Set Myrange = Nothing 
    Set Newrange = Nothing 
    Set ws = Nothing 
End Sub