Pimpin’ My Site

When Doug posted about Data Comparison Tricks, I saw Dick tell him to “pimp his site” in the comments.

Having a vivid imagination, this is what went through my head.

Yo Dawg!

Anyway, that’s what I’ll now proceed to do. (Having obtained Dick’s permission first of course!)

Here’s some stuff I’ve been working on recently.

A multi-field Find and Select/Replace tool.

AET Find and Replace

Although a bit old, (like me), some of the code came from this.

AET Cell Watch Form

Here’s the old post about it from back in 2009. (From my former blog, which I’ll also pimp!)

An alternative Status Bar that recognizes numbers even if the format is text. Woohoo!

AET Status Bar

And some games. (For the kids, but you can play too)
Grrr...
That’s enough pimpin’ for now. (I’m making new stuff as I write this) See you next time?

Copy Selection Sum to Clipboard

Last month I posted some metrics on the keyboard shortcuts I use. One of the pieces of code that I could not link to (because I’ve never posted it) is CopySum. I don’t remember what prompted me to write this little procedure, but it has been surprisingly useful. It sums the selected cells and puts that sum into the clipboard. That’s all it does.

Sub CopySum()

Dim doClip As MSForms.DataObject

On Error Resume Next

gclsAppEvents.AddLog "^+c", "CopySum"

Set doClip = New MSForms.DataObject

If TypeName(Selection) = "Range" Then
doClip.SetText Application.WorksheetFunction.Sum(Selection)
doClip.PutInClipboard
End If

End Sub

If I want to get a one-off sum of something and use it in another program, this comes in handy. I could SUM in a cell, copy that cell, paste it, and delete it. If I paste into Notepad, it’s fine, but if I try to paste into Outlook or even Gmail those programs try to get fancy and make an HTML table. Sometimes I just want the text.

One shortcoming of this procedure is that it doesn’t do well with filtered cells. The Selection includes both visible and hidden cells, but I probably only want visible. I’m changing the code to

doClip.SetText Application.WorksheetFunction.Subtotal(9, Selection)

so it works with filtered data.

Opening the Addin Dialog like a Pro

Back in the old days when Excel had menus and toolbars, a guy could use Alt+t+i to open the Addins dialog (Tools – Addins). But that would only work if there was an open workbook. No open workbook, no dialog. Now in the days of the Ribbon, the shortcut is Alt+f+t a a Alt+g (File – Options – Addins – Go). You don’t need to have a workbook open, which is nice, but there is a bit of delay between the two “a’s” in the keyboard sequence.

MS did a wonderful thing when they made the old 2003 menu navigation still work in later versions. Even though there’s no longer a Tools menu, you can still use Alt+t+i to open the dialog. Unfortunately you still need to have a workbook open for it to work. I can’t imagine why that is, but it is.

Well, it’s VBA to the rescue. You can show most any dialog with Applicaiton.Dialogs().Show. But showing the Addins dialog returns an error if there is not an active workbook, just like with the old menus. It’s trivial enough to fix, to wit:

Sub ShowAddinDialog()

Dim wb As Workbook

'Dialog won’t show if there’s no workbook showing
If ActiveWorkbook Is Nothing Then
Set wb = Workbooks.Add
End If

'Show addin dialog
Application.Dialogs(xlDialogAddinManager).Show

'Close wb if it was created
On Error Resume Next
wb.Close False

End Sub

That creates a new workbook if needed, then shows the dialog. It keeps track of whether it created a workbook and, if so, closes it without saving. Hardly worth your time to read this post, you say? You already knew about this, you say? Here’s the real magic. Those old 2003 commandbars still lurk behind the scenes in Excel. If you create new ones, they show up on the Add-ins tab. But you can modify the existing one too. I put this little gem in the Auto_Open macro in the same workbook as my ShowAddinDialog procedure.

With Application.CommandBars(1).Controls("Tools").Controls.Add(msoControlButton, , , 1)
.Caption = "&I"
.OnAction = "ShowAddinDialog"
End With

And then to clean it up in Auto_Close.

On Error Resume Next
Application.CommandBars(1).Controls("Tools").Controls("I").Delete

Commandbars(1) is the menu and Controls(“Tools”) is the Tools menu. I add a new control to position 1 on that Tools menu. I don’t need a fancy caption because I can’t see it anyway. I just need a caption with I as the hotkey. Whichever letter follows the ampersand (&) is the hotkey. The built-in addins menu item has a caption of Add-&Ins... making I the hotkey for it. But mine is higher up, so it wins.

In the previous post I referenced above, I add this macro to the QAT. But the muscle memory of Alt+t+i dies hard. Rather than retrain myself like a normal person, I’m embracing my quirks. I can now use Alt+t+i and get the desired results.

“Always” vs “Never”

I always select data from the top down, when I go to make a chart.
I never think to hit the Ctrl + Down Arrow first, so that I can select the range while leaving the active cell at the top.

I always end up with a chart waaay down at the bottom of that very long selection, where my active cell is.
I never want it all the way down there.

I always select the wayward chart, then move it gingerly up towards the Headings bar, in the vain hope that Excel will go into scroll mode, and let me release the chart where it belongs…at the top.
I never seem to hit that magic sweet spot, where Excel starts scrolling quicker than a crawl.

I always curse, then cut the chart, hit Ctrl + Up Arrow, then paste it up where it belongs.
I never remember this monkey business the next time I go to make a chart.

I always hope that MS will sort out basic usability stuff like this in the next release.
I never hold my breath.

“Yes please” vs “WTF?”

DDOE_Thank you vs. WTF_Formula Notation
Yes please.

DDOE_Thank you vs. WTF_Table Notation
WTF? That formula is the same as the last one, only it uses Table notation!

–Edit–

Out of interest, here’s how that 1st message looks in Excel 2010. (Apologies for the old-school look of these next two screenshots, vs the previous ones. I’m too tight to install Excel 2010 AND 2013 on all the machines in our house, so this screenshot comes from my wife’s PC, which runs XP, on account of that same monetary tightness.)

DDOE_Yes Please vs WTF_Old Correction

Let’s say I do decide to take the option offered in that 2nd bullet point – to close the message and correct the formula myself – and click NO. What do I get?

DDOE_Yes Please vs WTF_Old Yes

You told me that one click ago. Get out of my way, so I can do what I said I was going to do one click ago…i.e. fix the damn thing!

I spend heaps and heaps of my time on usability things when I build stuff in Excel. I can’t comprehend why these really crappy legacy usability issues are still perpetuated by the MS developers release after release. WTF.

Formula Auditing by RefTreeAnalyser: Objects included

Hi all,

I’ve been working on my RefTreeAnalyser again. What I’ve been up to this time is building tools which help with the analysis of dependencies which are mostly hidden from view:

  • Charts (series formula)
  • Pivot table (source data)
  • Data Validation formulas
  • Conditional Formatting formulas
  • Form controls (linked cell, listfillrange)
  • ActiveX controls (linked cell, listfillrange)
  • Picture objects (linked cell)

A new dialog has been added that shows all sources of the objects in your file:

Objects analysed for cell dependencies

Moreover, when you analyse a particular cell for its dependencies, objects are taken into account too (well, to be perfectly honest, only if you purchase a license):

RTAObjectsInRefs

If you haven’t already done so, why don’t you head over to my website and download the tool. The demo is free and (almost!) fully functional.

Regards,

Jan Karel Pieterse
www.jkp-ads.com

The Duality of Hyperlinks

Cells can contain two types of hyperlinks. There’s the embedded kind that you create using Insert – Hyperlink and the formula kind that you create using the HYPERLINK function. The function kind is nice because you can make the address and display text dynamic without using VBA. They’re just text arguments to a function and any function that modifies text can be used to modify them.

If you have HYPERLINK in a cell, the Insert – Hyperlink control is disabled (grayed out). Excel is wise enough to know that you shouldn’t have both kinds of hyperlinks in a cell. But it’s only half wise. Excel does not stop you from entering a HYPERLINK formula in a cell with an embedded hyperlink. If you do, you can end up with what seems like two hyperlinks in one cell.

I say “seems like” because Excel only recognizes one. And to be even more precise, it recognizes pieces of both hyperlinks to make one. Let me explain. If I type a URL in a cell, Excel converts it into a hyperlink. (Pro Tip: Press Ctrl+Z immediately after the conversion to undo the conversion, but keep the text). Let’s say I copy that down a few cells.

Now let’s say that I edit these cells to contain a HYPERLINK formula with a different address and a different display text. In this case, I’ve change the address by adding “my” in front of it and change the display text from the URL to the word “blog”.

If I hover over the new hyperlink, check what happens. There are three important properties of hyperlinks: Address (where it goes when you click), Text to Display (what shows up in the cell), and Tooltip (what pops up when you hover). With two hyperlinks, it appears that the Address and tooltip are driven by the embedded hyperlink and the Text to Display is driven by the formula.

I don’t know why it happens this way. I can’t even come up with a good story about how it’s an unintended consequence of some design decisions on Microsoft’s part. But it is what it is. I don’t know of any quick way to fix this through the user interface, but I wrote a macro to fix it.

Sub RemoveAndUpdateHyperlinks()

Dim rCell As Range

For Each rCell In Sheet1.Range("A2:A10").Cells
On Error Resume Next
rCell.Hyperlinks(1).Delete
On Error GoTo 0
rCell.Formula = rCell.Formula
Next rCell

End Sub

The code removes the embedded hyperlink and leaves the formula. The line that sets the formula equal to the formula is get the blue underline formatting back. The traditional hyperlink formatting disappears when you delete the hyperlink even though the formula remains. You can see that the tooltip now draws from the only remaining hyperlink, the formula one.

UnPivot Shootout

Jeff here, again. PivotTables again. Sorry ’bout that.

snb posted a very concise bit of code to unwind crosstabs over at Unpivot by SQL and so I got to wondering how my much longer routine handled in comparison.

My approach used SQL and lots of Union All statements to do the trick. And lots and lots of code. Whereas snb uses arrays to unwind the crosstab, which is fine so long as you don’t run out of worksheet to post the resulting flat-file in. Which is going to be the case 99.999999% of the time. And frankly, crosstabs in the other 0.000001% of cases deserve to be stuck as crosstabs.

At the same time, I thought I’d also test a previous approach of mine that uses the Multiple Consolidation trick that Mike Alexander outlines at Transposing a Dataset with a PivotTable. This approach:

  1. copies the specific contiguous or non-contiguous columns of data that the user want to turn into a flat file to a new sheet.
  2. concatenates all the columns on the left into one column, while putting the pipe character ‘|’ between each field so that later we can split these apart into separate columns again.
  3. creates a pivot table out of this using Excel’s ‘Multiple Consolidation Ranges’ option. Normally this type of pivot table is used for combining data on different sheets, but it has the side benefit of taking horizontal data and providing a vertical extract once you double click on the Grand Total field. This is also known as a ‘Reverse Pivot’.
  4. splits our pipe-delimited column back into seperate columns, using Excel’s Text-to-Column funcionality.

snb’s approach

snbs’ code for a dataset with two non-pivot fields down the left looked like this:

Sub M_snb()
sn = Cells(1).CurrentRegion
x = Cells(1).CurrentRegion.Rows(1).SpecialCells(2).Count
y = UBound(sn, 2) - x

ReDim sp(1 To x * (UBound(sn) - 1), 1 To 4)

For j = 1 To UBound(sp)
m = (j - 1) Mod (UBound(sn) - 1) + 2
n = (j - 1) \ (UBound(sn) - 1) + y + 1
sp(j, 1) = sn(m, 1)
sp(j, 2) = sn(m, 2)
sp(j, 3) = sn(1, n)
sp(j, 4) = sn(m, n)
Next

Cells(20, 1).Resize(UBound(sp), UBound(sp, 2)) = sp
End Sub

…which I’m sure you’ll all agree falls somewhere on the spectrum between good looking and positivity anorexic. So I put a bit of meat on it’s bones so that it prompts you for ranges and handles any sized cross-tab:


Sub UnPivot_snb()
Dim varSource As Variant
Dim j As Long
Dim m As Long
Dim n As Long
Dim i As Long
Dim varOutput As Variant
Dim rngCrossTab As Range
Dim rngLeftHeaders As Range
Dim rngRightHeaders As Range

'Identify where the ENTIRE crosstab table is
If rngCrossTab Is Nothing Then
On Error Resume Next
Set rngCrossTab = Application.InputBox( _
Title:="Please select the ENTIRE crosstab", _
prompt:="Please select the ENTIRE crosstab that you want to turn into a flat file", _
Type:=8, Default:=Selection.CurrentRegion.Address)
If Err.Number <> 0 Then
On Error GoTo errhandler
Err.Raise 999
Else: On Error GoTo errhandler
End If
rngCrossTab.Parent.Activate
rngCrossTab.Cells(1, 1).Select 'Returns them to the top left of the source table for convenience
End If

'Identify range containing columns of interest running down the table
If rngLeftHeaders Is Nothing Then
On Error Resume Next
Set rngLeftHeaders = Application.InputBox( _
Title:="Select the column HEADERS from the LEFT of the table that WON'T be aggregated", _
prompt:="Select the column HEADERS from the LEFT of the table that won't be aggregated", _
Default:=Selection.Address, Type:=8)
If Err.Number <> 0 Then
On Error GoTo errhandler
Err.Raise 999
Else: On Error GoTo errhandler
End If
Set rngLeftHeaders = rngLeftHeaders.Resize(1, rngLeftHeaders.Columns.Count) 'just in case they selected the entire column
rngLeftHeaders.Cells(1, rngLeftHeaders.Columns.Count + 1).Select 'Returns them to the right of the range they just selected
End If

If rngRightHeaders Is Nothing Then
'Identify range containing data and cross-tab headers running across the table
On Error Resume Next
Set rngRightHeaders = Application.InputBox( _
Title:="Select the column HEADERS from the RIGHT of the table that WILL be aggregated", _
prompt:="Select the column HEADERS from the RIGHT of the table that WILL be aggregated", _
Default:=Selection.Address, _
Type:=8)
If Err.Number <> 0 Then
On Error GoTo errhandler
Err.Raise 999
Else: On Error GoTo errhandler
End If
Set rngRightHeaders = rngRightHeaders.Resize(1, rngRightHeaders.Columns.Count) 'just in case they selected the entire column
rngCrossTab.Cells(1, 1).Select 'Returns them to the top left of the source table for convenience
End If

If strCrosstabName = "" Then
'Get the field name for the columns being consolidated e.g. 'Country' or 'Project'. note that reserved SQL words like 'Date' cannot be used
strCrosstabName = Application.InputBox( _
Title:="What name do you want to give the data field being aggregated?", _
prompt:="What name do you want to give the data field being aggregated? e.g. 'Date', 'Country', etc.", _
Default:="Date", _
Type:=2)
If strCrosstabName = "False" Then Err.Raise 999
End If

timetaken = Now()

varSource = rngCrossTab
lRightColumns = rngRightHeaders.Columns.Count
lLeftColumns = UBound(varSource, 2) - lRightColumns

ReDim varOutput(1 To lRightColumns * (UBound(varSource) - 1), 1 To lLeftColumns + 2)

For j = 1 To UBound(varOutput)
m = (j - 1) Mod (UBound(varSource) - 1) + 2
n = (j - 1) \ (UBound(varSource) - 1) + lLeftColumns + 1
varOutput(j, lLeftColumns + 1) = varSource(1, n)
varOutput(j, lLeftColumns + 2) = varSource(m, n)
For i = 1 To lLeftColumns
varOutput(j, i) = varSource(m, i)
Next i
Next j

Worksheets.Add

With Cells(1, 1)
.Resize(, lLeftColumns).Value = rngLeftHeaders.Value
.Offset(, lLeftColumns).Value = strCrosstabName
.Offset(, lLeftColumns + 1).Value = "Value"
.Offset(1, 0).Resize(UBound(varOutput), UBound(varOutput, 2)) = varOutput
End With

timetaken = timetaken - Now()

Debug.Print "UnPivot - snb: " & Now() & " Time Taken: " & Format(timetaken, "HH:MM:SS")
errhandler:
If Err.Number <> 0 Then
Dim strErrMsg As String
Select Case Err.Number
Case 999: 'User pushed cancel. Do nothing
Case 998 'Worksheet does not have enough rows to hold flat file
strErrMsg = "Oops, there's not enough rows in the worsheet to hold a flatfile of all the data you have selected. "
strErrMsg = strErrMsg & vbNewLine & vbNewLine
strErrMsg = strErrMsg & "Your dataset will take up " & Format(rngRightHeaders.CurrentRegion.Count, "#,##0") & " rows of data "
strErrMsg = strErrMsg & "but your worksheet only allows " & Format(Application.Range("A:A").Count, "#,##0") & " rows of data. "
strErrMsg = strErrMsg & vbNewLine & vbNewLine
MsgBox strErrMsg

Case Else
MsgBox Err.Description, vbCritical, "UnPivot_snb"

End Select

End If
End Sub

Talk about yo-yo dieting!

Multiple Consolidation Trick approach

And here’s my code that uses the Multiple Consolidation trick:


Option Explicit

Sub CallUnPivotByConsolidation()
Call UnPivotByConsolidation
End Sub

Function UnPivotByConsolidation( _
Optional rngCrossTab As Range, _
Optional rngLeftHeaders As Range, _
Optional rngRightHeaders As Range, _
Optional strCrosstabName As String) As Boolean

Dim wksTempCrosstab As Worksheet
Dim wksInitial As Worksheet
Dim strConcat As String
Dim strCell As String
Dim strFormula As String
Dim iCount As Integer
Dim iColumns As Integer
Dim iRows As Integer
Dim rngInputData As Range
Dim wksPT As Worksheet
Dim wksFlatFile As Worksheet
Dim pc As PivotCache
Dim pt As PivotTable
Dim rngKeyFormula As Range
Dim rngRowHeaders As Range
Dim rngPT_GrandTotal As Range, rngPTData As Range
Dim lPT_Rows As Long
Dim iPT_Columns As Integer
Dim iKeyColumns As Integer
Dim varRowHeadings As Variant

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Part one: '
'Code prompts user to select contiguous or non-contiguous columns of data '
'from a crosstab table, and writes it to a new sheet in a contiguous range. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Set wksInitial = ActiveSheet

'Identify where the ENTIRE crosstab table is
If rngCrossTab Is Nothing Then
On Error Resume Next
Set rngCrossTab = Application.InputBox( _
Title:="Please select the ENTIRE crosstab", _
prompt:="Please select the ENTIRE crosstab that you want to turn into a flat file", _
Type:=8, Default:=Selection.CurrentRegion.Address)
If Err.Number <> 0 Then
On Error GoTo errhandler
Err.Raise 999
Else: On Error GoTo errhandler
End If
rngCrossTab.Parent.Activate
rngCrossTab.Cells(1, 1).Select 'Returns them to the top left of the source table for convenience
End If

'Identify range containing columns of interest running down the table
If rngLeftHeaders Is Nothing Then
On Error Resume Next
Set rngLeftHeaders = Application.InputBox( _
Title:="Select the column HEADERS from the LEFT of the table that WON'T be aggregated", _
prompt:="Select the column HEADERS from the LEFT of the table that won't be aggregated", _
Default:=Selection.Address, Type:=8)
If Err.Number <> 0 Then
On Error GoTo errhandler
Err.Raise 999
Else: On Error GoTo errhandler
End If
Set rngLeftHeaders = Intersect(rngLeftHeaders.EntireColumn, rngCrossTab)
rngLeftHeaders.Cells(1, rngLeftHeaders.Columns.Count + 1).Select 'Returns them to the right of the range they just selected
End If

If rngRightHeaders Is Nothing Then
'Identify range containing data and cross-tab headers running across the table
On Error Resume Next
Set rngRightHeaders = Application.InputBox( _
Title:="Select the column HEADERS from the RIGHT of the table that WILL be aggregated", _
prompt:="Select the column HEADERS from the RIGHT of the table that WILL be aggregated", _
Default:=Selection.Address, _
Type:=8)
If Err.Number <> 0 Then
On Error GoTo errhandler
Err.Raise 999
Else: On Error GoTo errhandler
End If
Set rngRightHeaders = Intersect(rngRightHeaders.EntireColumn, rngCrossTab)
rngCrossTab.Cells(1, 1).Select 'Returns them to the top left of the source table for convenience
End If

If strCrosstabName = "" Then
'Get the field name for the columns being consolidated e.g. 'Country' or 'Project'. note that reserved SQL words like 'Date' cannot be used
strCrosstabName = Application.InputBox( _
Title:="What name do you want to give the data field being aggregated?", _
prompt:="What name do you want to give the data field being aggregated? e.g. 'Date', 'Country', etc.", _
Default:="Date", _
Type:=2)
If strCrosstabName = "False" Then Err.Raise 999
End If

With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With

'Set up a temp worksheet to house our crosstab data
For Each wksTempCrosstab In ActiveWorkbook.Worksheets
If wksTempCrosstab.Name = "TempCrosstab" Then wksTempCrosstab.Delete
Next
Set wksTempCrosstab = Worksheets.Add
wksTempCrosstab.Name = "TempCrosstab"

'Copy data to the temp worksheet "TempCrosstab"
rngLeftHeaders.Copy wksTempCrosstab.[A1]
Set rngLeftHeaders = wksTempCrosstab.[A1].CurrentRegion
rngLeftHeaders.Name = "TempCrosstab!appRowFields"
rngRightHeaders.Copy wksTempCrosstab.[A1].Offset(0, rngLeftHeaders.Columns.Count)
Set rngRightHeaders = wksTempCrosstab.[A1].Resize(rngRightHeaders.Rows.Count, rngRightHeaders.Columns.Count)
rngRightHeaders.Name = "TempCrosstab!appCrosstabFields"

'Work out if the worksheet has enough rows to fit a crosstab in
If rngRightHeaders.CurrentRegion.Count > Columns(1).Rows.Count Then Err.Raise 998

varRowHeadings = rngLeftHeaders.Value

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Part Two: '
'Construct a new pipe-delimited column out of the columns that run down the '
'left of the crosstab, and then delete the original columns used to do this '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

strFormula = "=RC[1]"
strConcat = "&""|""&"

iColumns = Range("TempCrosstab!appRowFields").Columns.Count

For iCount = 2 To iColumns
strCell = "RC[" & iCount & "]"
strFormula = strFormula & strConcat & strCell
Next iCount

With Worksheets("TempCrosstab")
.Columns("A:A").Insert Shift:=xlToRight
iRows = Intersect(Worksheets("TempCrosstab").Columns(2), Worksheets("TempCrosstab").UsedRange).Rows.Count
.Range("A2:A" & iRows).FormulaR1C1 = strFormula
.Range("A2:A" & iRows).Value = .Range("A2:A" & iRows).Value
.Range("appRowFields").Delete Shift:=xlToLeft
End With

Names("TempCrosstab!appRowFields").Delete

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Part Three: '
'Use data to create a pivot table using "Multiple Consolidation Ranges" option, '
'which has the side benefit of providing a vertical extract once you double '
'click on the Grand Total field '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set rngInputData = Worksheets("TempCrosstab").[A2].CurrentRegion
rngInputData.Name = "SourceData"

'Find out the number of columns contained within the primary key
iKeyColumns = Len([SourceData].Cells(2, 1).Value) - Len(Replace([SourceData].Cells(2, 1).Value, "|", "")) + 1

' Create the intermediate pivot from which to extract flat file
Set pc = ActiveWorkbook.PivotCaches.Add(SourceType:=xlConsolidation, SourceData:=Array("=sourcedata", "Item1"))
Set wksPT = Worksheets.Add
Set pt = wksPT.PivotTables.Add(PivotCache:=pc, TableDestination:=[A3])

' Get address of PT Total field, then double click it to get underlying records
Set rngPTData = pt.DataBodyRange
lPT_Rows = rngPTData.Rows.Count
iPT_Columns = rngPTData.Columns.Count
Set rngPT_GrandTotal = rngPTData.Cells(1).Offset(lPT_Rows - 1, iPT_Columns - 1)
rngPTData.Cells(1).Offset(lPT_Rows - 1, iPT_Columns - 1).Select
Selection.ShowDetail = True
Set wksFlatFile = ActiveSheet

' Delete current "Flat_File" worksheet if it exists, name current sheet "Flat_File"
On Error Resume Next
Sheets("Flat_File").Delete
On Error GoTo 0
wksFlatFile.Name = "Flat_File"

' Delete unneeded column and the now-unneeded TempCrosstab and wksPT worksheets
Columns(4).Delete Shift:=xlToLeft
wksPT.Delete
Worksheets("TempCrosstab").Delete

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Part Four: '
'split our pipe-delimited column back into seperate columns, using Excel's '
'Text-to-Column funcionality. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Set rngKeyFormula = Worksheets("Flat_File").Range("A2")
rngKeyFormula.Name = "appKeyFormula"

'Find out the number of columns contained within the primary key
iKeyColumns = Len([appKeyFormula].Cells(2, 1).Value) - Len(Replace([appKeyFormula].Cells(2, 1).Value, "|", "")) + 1

'Insert columns to the left that we will unpack the Unique Key to
[B1].Resize(, iKeyColumns).EntireColumn.Insert

'Split the Unique Key column into its constituent parts,
'using Excel's Text-to-Columns functionality
Worksheets("Flat_File").Columns("A:A").Select
Selection.TextToColumns Destination:=Range("b1"), DataType:=xlDelimited, _
ConsecutiveDelimiter:=False, Other:=True, OtherChar:="|"

'Delete old composite key, add original column headers
[A1].EntireColumn.Delete
Set rngRowHeaders = [A1].Resize(1, iKeyColumns)
rngRowHeaders.Value = varRowHeadings

'Add new column header with crosstab data name
[A1].Offset(0, iKeyColumns).Value = strCrosstabName
Selection.CurrentRegion.Columns.AutoFit

Worksheets("Flat_File").Select

errhandler:
If Err.Number <> 0 Then
Dim strErrMsg As String
Select Case Err.Number
Case 999: 'User pushed cancel. Do nothing
Case 998 'Worksheet does not have enough rows to hold flat file
strErrMsg = "Oops, there's not enough rows in the worsheet to hold a flatfile of all the data you have selected. "
strErrMsg = strErrMsg & vbNewLine & vbNewLine
strErrMsg = strErrMsg & "Your dataset will take up " & Format(rngRightHeaders.CurrentRegion.Count, "#,##0") & " rows of data "
strErrMsg = strErrMsg & "but your worksheet only allows " & Format(Application.Range("A:A").Count, "#,##0") & " rows of data. "
strErrMsg = strErrMsg & vbNewLine & vbNewLine
MsgBox strErrMsg

Case Else
MsgBox Err.Description, vbCritical, "UnPivotByConsolidation"

End Select

End If

With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Function

The SQL appoach is the same as I published here.

And the winner is…

…snb. By a long shot. With the ever-so-slight caveat that you’re crosstabs are not so stupidly fat that the resulting flat file exceeds the number of rows in Excel.

Here’s how things stacked up on a 53 Column x 2146 Row crosstab, which gives a 117,738 row flat-file:

Approach Time (M:SS)
snb 0:01
UnPivotByConsolidation 0:04
UnPivotBySQL 0:14

 
And here’s how things stacked up on a 53 Columns x 19,780 Row crosstab, giving a 1,048,340 row flat-file (i.e. practically the biggest sized crosstab that you can unwind):

Approach Time (M:SS)
snb 0:19
UnPivotByConsolidation 0:42
UnPivotBySQL 2:17

 
So there you have it. Use snb’s code. Unless you have no choice but to use my longer, slower SQL approach.

Update 26 November 2013
It was remiss of me not to mention the Data Normalizer routine in Doug Glancy’s great yoursumbuddy blog, which is just about as fast as snb’s approach below. Go check it out, and subscribe to Doug’s blog while you’re there if you haven’t already.

If you don’t want the hassle of working out which to use, here’s a routine that uses snb’s if possible, and otherwise uses mine:

Option Explicit
Sub Call_UnPivot()
UnPivot
End Sub

Function unpivot(Optional rngCrossTab As Range, _
Optional rngLeftHeaders As Range, _
Optional rngRightHeaders As Range, _
Optional strCrosstabName As String, _
Optional rngOutput As Range, _
Optional bSkipBlanks As Boolean = False) As Boolean

' Desc: Turns a crosstab file into a flatfile using array manipulation.
' If the resulting flat file will be too long to fit in the worksheet,
' the routine uses SQL and lots of 'UNION ALL' statements to do the
' equivalent of the 'UNPfaddIVOT' command in SQL Server (which is not available
' in Excel)and writes the result directly to a PivotTable

' Base code for the SQL UnPivot derived from from Fazza at MR EXCEL forum:
' http://www.mrexcel.com/forum/showthread.php?315768-Creating-a-pivot-table-with-multiple-sheets
' The Microsoft JET/ACE Database engine has a hard limit of 50 'UNION ALL' clauses, but Fazza's
' code gets around this by creating sublocks of up to 25 SELECT/UNION ALL statements, and
' then unioning these.

' Programmer: Jeff Weir
' Contact: weir.jeff@gmail.com

' Name/Version: Date: Ini: Modification:
' UnPivot V1 20131122 JSW Original Development

' Inputs: Range of the entile crosstab
' Range of columns down the left that WON'T be normalized
' Range of columns down the right that WILL be normalize
' String containing the name to give columns that will be normalized

' Outputs: A pivottable of the input data on a new worksheet.

' Example:

' It takes a crosstabulated table that looks like this:

' Country Sector 1990 1991 ... 2009
' =============================================================================
' Australia Energy 290,872 296,887 ... 417,355
' New Zealand Energy 23,915 25,738 ... 31,361
' United States Energy 5,254,607 5,357,253 ... 5,751,106
' Australia Manufacturing 35,648 35,207 ... 44,514
' New Zealand Manufacturing 4,389 4,845 ... 4,907
' United States Manufacturing 852,424 837,828 ... 735,902
' Australia Transport 62,121 61,504 ... 83,645
' New Zealand Transport 8,679 8,696 ... 13,783
' United States Transport 1,484,909 1,447,234 ... 1,722,501

' And it returns the same data in a recordset organised like this:

' Country Sector Year Value
' ====================================================
' Australia Energy 1990 290,872
' New Zealand Energy 1990 23,915
' United States Energy 1990 5,254,607
' Australia Manufacturing 1990 35,648
' New Zealand Manufacturing 1990 4,389
' United States Manufacturing 1990 852,424
' Australia Transport 1990 62,121
' New Zealand Transport 1990 8,679
' United States Transport 1990 1,484,909
' Australia Energy 1991 296,887
' New Zealand Energy 1991 25,738
' United States Energy 1991 5,357,253
' Australia Manufacturing 1991 35,207
' New Zealand Manufacturing 1991 4,845
' United States Manufacturing 1991 837,828
' Australia Transport 1991 61,504
' New Zealand Transport 1991 8,696
' United States Transport 1991 1,447,234
' ... ... ... ...
' ... ... ... ...
' ... ... ... ...
' Australia Energy 2009 417,355
' New Zealand Energy 2009 31,361
' United States Energy 2009 5,751,106
' Australia Manufacturing 2009 44,514
' New Zealand Manufacturing 2009 4,907
' United States Manufacturing 2009 735,902
' Australia Transport 2009 83,645
' New Zealand Transport 2009 13,783
' United States Transport 2009 1,722,501

Const lngMAX_UNIONS As Long = 25

Dim varSource As Variant
Dim varOutput As Variant
Dim lLeftColumns As Long
Dim lRightColumns As Long
Dim i As Long
Dim j As Long
Dim m As Long
Dim n As Long
Dim lOutputRows As Long
Dim arSQL() As String
Dim arTemp() As String
Dim sTempFilePath As String
Dim objPivotCache As PivotCache
Dim objRS As Object
Dim oConn As Object
Dim sConnection As String
Dim wks As Worksheet
Dim wksNew As Worksheet
Dim cell As Range
Dim strLeftHeaders As String
Dim wksSource As Worksheet
Dim pt As PivotTable
Dim rngCurrentHeader As Range
Dim timetaken As Date
Dim strMsg As String
Dim varAnswer As Variant

Const Success As Boolean = True
Const Failure As Boolean = False

unpivot = Failure

'Identify where the ENTIRE crosstab table is
If rngCrossTab Is Nothing Then
Application.ScreenUpdating = True
On Error Resume Next
Set rngCrossTab = Application.InputBox( _
Title:="Please select the ENTIRE crosstab", _
Prompt:="Please select the ENTIRE crosstab that you want to turn into a flat file", _
Type:=8, Default:=Selection.CurrentRegion.Address)
If Err.Number <> 0 Then
On Error GoTo ErrHandler
Err.Raise 999
Else: On Error GoTo ErrHandler
End If
rngCrossTab.Parent.Activate
rngCrossTab.Cells(1, 1).Select 'Returns them to the top left of the source table for convenience
End If

'Identify range containing columns of interest running down the table
If rngLeftHeaders Is Nothing Then
On Error Resume Next
Set rngLeftHeaders = Application.InputBox( _
Title:="Select the column HEADERS from the LEFT of the table that WON'T be aggregated", _
Prompt:="Select the column HEADERS from the LEFT of the table that won't be aggregated", _
Default:=Selection.Address, Type:=8)
If Err.Number <> 0 Then
On Error GoTo ErrHandler
Err.Raise 999
Else: On Error GoTo ErrHandler
End If
Set rngLeftHeaders = rngLeftHeaders.Resize(1, rngLeftHeaders.Columns.Count) 'just in case they selected the entire column
Range(rngLeftHeaders.Cells(1, rngLeftHeaders.Columns.Count + 1), rngLeftHeaders.Cells(1, rngLeftHeaders.Columns.Count + 1).End(xlToRight)).Select 'Returns them to the right of the range they just selected
End If

If rngRightHeaders Is Nothing Then
'Identify range containing data and cross-tab headers running across the table
On Error Resume Next
Set rngRightHeaders = Application.InputBox( _
Title:="Select the column HEADERS from the RIGHT of the table that WILL be aggregated", _
Prompt:="Select the column HEADERS from the RIGHT of the table that WILL be aggregated", _
Default:=Selection.Address, _
Type:=8)
If Err.Number <> 0 Then
On Error GoTo ErrHandler
Err.Raise 999
Else: On Error GoTo ErrHandler
End If
Set rngRightHeaders = rngRightHeaders.Resize(1, rngRightHeaders.Columns.Count) 'just in case they selected the entire column
rngCrossTab.Cells(1, 1).Select 'Returns them to the top left of the source table for convenience
End If

If strCrosstabName = "" Then
'Get the field name for the columns being consolidated e.g. 'Country' or 'Project'. note that reserved SQL words like 'Date' cannot be used
strCrosstabName = Application.InputBox( _
Title:="What name do you want to give the data field being aggregated?", _
Prompt:="What name do you want to give the data field being aggregated? e.g. 'Date', 'Country', etc.", _
Default:="Date", _
Type:=2)
If strCrosstabName = "False" Then Err.Raise 999
End If

If rngOutput Is Nothing Then
'Identify range containing data and cross-tab headers running across the table
On Error Resume Next
Set rngOutput = Application.InputBox( _
Title:="Where do you want to output the data", _
Prompt:="Select the top left cell where you want the transformed data to be output", _
Default:=Cells(ActiveSheet.UsedRange.row, ActiveSheet.UsedRange.Columns.Count + ActiveSheet.UsedRange.Column + 1).Address, _
Type:=8)
If Err.Number <> 0 Then
On Error GoTo ErrHandler
Err.Raise 999
Else: On Error GoTo ErrHandler
End If
End If

timetaken = Now()
Application.ScreenUpdating = False

'Work out if the worksheet has enough rows to fit a crosstab in
If Intersect(rngRightHeaders.EntireColumn, rngCrossTab).Cells.Count <= Columns(1).Rows.Count Then 'Resulting flat file will fit on the sheet, so use array manipulation. varSource = rngCrossTab lRightColumns = rngRightHeaders.Columns.Count lLeftColumns = UBound(varSource, 2) - lRightColumns If Not bSkipBlanks Then ReDim varOutput(1 To lRightColumns * (UBound(varSource) - 1), 1 To lLeftColumns + 2) Else lOutputRows = Application.WorksheetFunction.CountA(Intersect([appRightHeaders].EntireColumn, rngCrossTab)) - [appRightHeaders].Cells.Count ReDim varOutput(1 To lOutputRows, 1 To lLeftColumns + 2) End If If Not bSkipBlanks Then For j = 1 To UBound(varOutput) m = (j - 1) Mod (UBound(varSource) - 1) + 2 n = (j - 1) \ (UBound(varSource) - 1) + lLeftColumns + 1 varOutput(j, lLeftColumns + 1) = varSource(1, n) varOutput(j, lLeftColumns + 2) = varSource(m, n) For i = 1 To lLeftColumns varOutput(j, i) = varSource(m, i) Next i Next j Else lOutputRows = 1 For j = 1 To Intersect([appRightHeaders].EntireColumn, rngCrossTab).Cells.Count - [appRightHeaders].Cells.Count m = (j - 1) Mod (UBound(varSource) - 1) + 2 n = (j - 1) \ (UBound(varSource) - 1) + lLeftColumns + 1 If Not IsEmpty(varSource(m, n)) Then varOutput(lOutputRows, lLeftColumns + 1) = varSource(1, n) varOutput(lOutputRows, lLeftColumns + 2) = varSource(m, n) For i = 1 To lLeftColumns varOutput(lOutputRows, i) = varSource(m, i) Next i lOutputRows = lOutputRows + 1 End If Next j End If With rngOutput .Resize(, lLeftColumns).Value = rngLeftHeaders.Value .Offset(, lLeftColumns).Value = strCrosstabName .Offset(, lLeftColumns + 1).Value = "Quantity" .Offset(1, 0).Resize(UBound(varOutput), UBound(varOutput, 2)) = varOutput End With Else 'Resulting flat file will fit on the sheet, so use SQL and write result directly to a pivot strMsg = " I can't turn this crosstab into a flat file, because the crosstab is so large that" strMsg = strMsg & " the resulting flat file will be too big to fit in a worksheet. " strMsg = strMsg & vbNewLine & vbNewLine strMsg = strMsg & " However, I can still turn this information directly into a PivotTable if you want." strMsg = strMsg & " Note that this might take several minutes. Do you wish to proceed?" varAnswer = MsgBox(Prompt:=strMsg, Buttons:=vbOK + vbCancel + vbCritical, Title:="Crosstab too large!") If varAnswer <> 6 Then Err.Raise 999

If ActiveWorkbook.Path <> "" Then 'can only proceed if the workbook has been saved somewhere
Set wksSource = rngLeftHeaders.Parent

'Build part of SQL Statement that deals with 'static' columns i.e. the ones down the left
For Each cell In rngLeftHeaders

'For some reason this approach doesn't like columns with numeric headers.
' My solution in the below line is to prefix any numeric characters with
' an apostrophe to render them non-numeric, and restore them back to numeric
' after the query has run

If IsNumeric(cell) Or IsDate(cell) Then cell.Value = "'" & cell.Value
strLeftHeaders = strLeftHeaders & "[" & cell.Value & "], "

Next cell

ReDim arTemp(1 To lngMAX_UNIONS) 'currently 25 as per declaration at top of module

ReDim arSQL(1 To (rngRightHeaders.Count - 1) \ lngMAX_UNIONS + 1)

For i = LBound(arSQL) To UBound(arSQL) - 1
For j = LBound(arTemp) To UBound(arTemp)
Set rngCurrentHeader = rngRightHeaders(1, (i - 1) * lngMAX_UNIONS + j)

arTemp(j) = "SELECT " & strLeftHeaders & "[" & rngCurrentHeader.Value & "] AS Total, '" & rngCurrentHeader.Value & "' AS [" & strCrosstabName & "] FROM [" & rngCurrentHeader.Parent.Name & "$" & Replace(rngCrossTab.Address, "$", "") & "]"
If IsNumeric(rngCurrentHeader) Or IsDate(rngCurrentHeader) Then rngCurrentHeader.Value = "'" & rngCurrentHeader.Value 'As per above, can't have numeric headers

Next j
arSQL(i) = "(" & Join$(arTemp, vbCr & "UNION ALL ") & ")"
Next i

ReDim arTemp(1 To rngRightHeaders.Count - (i - 1) * lngMAX_UNIONS)
For j = LBound(arTemp) To UBound(arTemp)
Set rngCurrentHeader = rngRightHeaders(1, (i - 1) * lngMAX_UNIONS + j)
arTemp(j) = "SELECT " & strLeftHeaders & "[" & rngCurrentHeader.Value & "] AS Total, '" & rngCurrentHeader.Value & "' AS [" & strCrosstabName & "] FROM [" & rngCurrentHeader.Parent.Name & "$" & Replace(rngCrossTab.Address, "$", "") & "]"
If IsNumeric(rngCurrentHeader) Or IsDate(rngCurrentHeader) Then rngCurrentHeader.Value = "'" & rngCurrentHeader.Value 'As per above, can't have numeric headers

Next j
arSQL(i) = "(" & Join$(arTemp, vbCr & "UNION ALL ") & ")"
'Debug.Print Join$(arSQL, vbCr & "UNION ALL" & vbCr)

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' When using ADO with Excel data, there is a documented bug
' causing a memory leak unless the data is in a different
' workbook from the ADO workbook.
' http://support.microsoft.com/kb/319998
' So the work-around is to save a temp version somewhere else,
' then pull the data from the temp version, then delete the
' temp copy
sTempFilePath = ActiveWorkbook.Path
sTempFilePath = sTempFilePath & "\" & "TempFile_" & Format(Time(), "hhmmss") & ".xlsm"
ActiveWorkbook.SaveCopyAs sTempFilePath
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

If Application.Version >= 12 Then
'use ACE provider connection string
sConnection = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & sTempFilePath & ";Extended Properties=""Excel 12.0;"""
Else
'use JET provider connection string
sConnection = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & sTempFilePath & ";Extended Properties=""Excel 8.0;"""
End If

Set objRS = CreateObject("ADODB.Recordset")
Set oConn = CreateObject("ADODB.Connection")

' Open the ADO connection to our temp Excel workbook
oConn.Open sConnection

' Open the recordset as a result of executing the SQL query
objRS.Open Source:=Join$(arSQL, vbCr & "UNION ALL" & vbCr), ActiveConnection:=oConn, CursorType:=3 'adOpenStatic !!!NOTE!!! we have to use a numerical constant here, because as we are using late binding Excel doesn't have a clue what 'adOpenStatic' means

Set objPivotCache = ActiveWorkbook.PivotCaches.Create(xlExternal)
Set objPivotCache.Recordset = objRS
Set objRS = Nothing

Set pt = objPivotCache.CreatePivotTable(TableDestination:=rngOutput)
Set objPivotCache = Nothing

'Turn any numerical headings back to numbers by effectively removing any apostrophes in front
For Each cell In rngLeftHeaders
If IsNumeric(cell) Or IsDate(cell) Then cell.Value = cell.Value
Next cell
For Each cell In rngRightHeaders
If IsNumeric(cell) Or IsDate(cell) Then cell.Value = cell.Value
Next cell

With pt
.ManualUpdate = True 'stops the pt refreshing while we make chages to it.
If Application.Version >= 14 Then TabularLayout pt

For Each cell In rngLeftHeaders
With .PivotFields(cell.Value)
.Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
End With
Next cell

With .PivotFields(strCrosstabName)
.Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
End With

With .PivotFields("Total")
.Orientation = xlDataField
.Function = xlSum
End With
.ManualUpdate = False
End With
Else: MsgBox "You must first save the workbook for this code to work."
End If
End If

unpivot = Success

timetaken = timetaken - Now()
Debug.Print "UnPivot: " & Now() & " Time Taken: " & Format(timetaken, "HH:MM:SS")

ErrHandler:
If Err.Number <> 0 Then
Select Case Err.Number
Case 999: 'User pushed cancel.
Case Else: MsgBox "Whoops, there was an error: Error#" & Err.Number & vbCrLf & Err.Description _
, vbCritical, "Error", Err.HelpFile, Err.HelpContext
End Select
End If

Application.ScreenUpdating = True

End Function

Private Sub TabularLayout(pt As PivotTable)
With pt
.RepeatAllLabels xlRepeatLabels
.RowAxisLayout xlTabularRow
End With
End Sub