Excel

Delete then restore all data tables in a workbook

Ease of Use

Intermediate

Version tested with

2000, 2003 

Submitted by:

brettdj

Description:

The MapDataTables macro deletes the data table calculations and "maps" them to a hidden sheet The RestoreTables macro restores the data tables to the condition they were in WHEN the MapDataTables macro was run. 

Discussion:

Data Tables are an invaluable tool for the Excel power user when looking at sensitivity analysis. However the calculation overhead can be high, and it is not always possible to disable calculation of data tables via Tools .. Options. For example, a monte carlo add-in such as Crystal Ball will recalculate the entire spreadsheet during each iteration, this normally means that the data tables must be deleted prior to running Crystall Ball, and then restored afterwards. This code takes care of the delete and restoration for the user. 

Code:

instructions for use

			

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

How to use:

  1. Copy the code above.
  2. Open your workbook.
  3. Hit Alt+F11 to open the Visual Basic Editor (VBE).
  4. From the menu, choose Insert-Module.
  5. Paste the code into the code window at right.
  6. Close the VBE, and save the file if desired.
 

Test the code:

  1. To delete tables, run the macro MapDataTables by going to Tools-Macro-Macros and double-click MapDataTables
  2. To restore tables, run the macro RestoreTables by going to Tools-Macro-Macros and double-click RestoreTables
 

Sample File:

MapDataTables(KB21).zip 27.92KB 

Approved by mdmackillop


This entry has been viewed 334 times.

Please read our Legal Information and Privacy Policy
Copyright @2004 - 2014 VBA Express