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
|