Sending Images via WinSCP

Since my recent move to Digital Ocean for hosting, I’ve had to make a change to how I upload images for this blog. I used to create an FTP file and a batch file, but as far as I know that doesn’t support SFTP. I’m using WinSCP to transfer files manually and learned that it has a command line interface. I made a procedure called SendViaSCP to replace my SendViaFTP.

Public Sub SendViaSCP(vFname As Variant)

Dim aScript() As String
Dim i As Long

ReDim aScript(1 To 4 + UBound(vFname))

aScript(1) = "option batch abort"
aScript(2) = "option confirm off"
aScript(3) = "open sftp://username:password@000.000.000.000"
aScript(UBound(aScript)) = "exit"

For i = LBound(vFname) To UBound(vFname)
aScript(3 + i) = "put " & Dir(vFname(i)) & " /home/wordpress/public_html/blogpix/"
Next i

Open "winscpup.txt" For Output As #1
Print #1, Join(aScript, vbNewLine)
Close #1

Shell "winscpup.bat"

End Sub

The vFname arguments is a variant array that holds all of the files I selected from Application.GetOpenFileName. The aScript array holds three lines of setup, a line for each file, and an exit line.

The commands are joined together and written to a batch file and the batch file is run. It doesn’t solve the problem that Billkamm and Haines solved of having your username and password in a batch file, but I can live with it.

You might be wondering why I don’t just use the file upload functions in WordPress. What fun would that be?

Subtracting Cells in the Status Bar

Sometimes I just want to quickly see the difference between two cells or groups of cells. Excel puts some great aggregates in the status bar.

and you can even customize them. Right click on the those aggregates.

But I wanted the difference. So I wrote some code to find it. I already had a class module with an Application object declared WithEvents, so I added this SheetSelectionChange event procedure.

Private Sub mxlApp_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

If TypeName(Selection) = "Range" Then
ShowDifferenceStatus Selection
End If

End Sub

That event procedure calls this procedure in a standard module.

Public Sub ShowDifferenceStatus(rSel As Range)

Dim wf As WorksheetFunction
Dim vStatus As Variant

On Error Resume Next

Set wf = Application.WorksheetFunction

If rSel.Areas.Count = 1 Then
If rSel.Columns.Count = 2 Then
vStatus = "Difference: " & Format(wf.Sum(rSel.Columns(1)) - wf.Sum(rSel.Columns(2)), "#,##0.00")
ElseIf rSel.Rows.Count = 2 Then
vStatus = "Difference: " & Format(wf.Sum(rSel.Rows(1)) - wf.Sum(rSel.Rows(2)), "#,##0.00")
Else
vStatus = False
End If
ElseIf rSel.Areas.Count = 2 Then
If (rSel.Areas(1).Columns.Count = 1 And rSel.Areas(2).Columns.Count = 1) Or _
(rSel.Areas(1).Rows.Count = 1 And rSel.Areas(2).Rows.Count = 1) Then

vStatus = "Difference: " & Format(wf.Sum(rSel.Areas(1)) - wf.Sum(rSel.Areas(2)), "#,##0.00")
End If
Else
vStatus = False
End If

Application.StatusBar = vStatus

End Sub

If the selection is contiguous (Areas.Count = 1), it determines if there are two columns or two rows. Then it uses the SUM worksheet function to sum up the first and subtract the sum of the second. Anything other that two columns tow rows resets the StatusBar by setting it to False. Subtracting one cell from the other is easy enough, but I wanted the ability to subtract one column from the other (or one row). Using SUM also avoids me having to check for text or other nonsense that SUM does automatically. Here’s one where I only have one Area selected and it contains two columns. It sums the numbers in column B and subtracts the sum of column C.

When the selection is not contiguous (Areas.Count = 2), then it determines if both areas have only one column or only one row. If either has more than one, it resets the status bar. But if they both have one (of either), it subtracts them. Here I’ve selected B2:B3, then held down the Control key while I selected C3:C4. That’s two areas, but each only has one column, so it assumes I want to subtract columns.

The next feature I want to add is to recognize filtered data. Often I’m working with a filtered Table and although two cells appear to be adjacent, selecting them without holding down Control really selects all those filtered cells in between. I guess I’ll need to loop through and determine what’s visible, build a range from only those cells, and sum that. For now, I’m just holding down control and using the mouse to select them. If you’re not familiar, the “mouse” is that blob of plastic several inches away from home row (aka the productivity killer). Excuse me while I get off my soap box and finish this post.

I tried to glean the NumberFormat of the cells selected and use that in the display. You can see from the code above that I punted and just used a comma and two decimals. But that stinks for really small numbers. Originally, I had something like

vStatus = "Difference: " & Format(wf.Sum(rSel.Columns(1)) - wf.Sum(rSel.Columns(2)), rSel.Cells(1).NumberFormat)

But look at the craziness when the cell as the Accounting format (_(* #,##0.00_);_(* (#,##0.00);_(* "-"??_);_(@_))

It works well for times though.

Apparently the syntax for cell formatting is slightly different than for the VBA.Format function. I haven’t worked out what the differences are, but maybe someday I will.

Identifying duplicates between multiple lists

Howdy folks. Jeff here, back from my summer holiday in the Coromandel Peninsula in the North Island of New Zealand, where I’ve been staring at this for the last 21 days:
DDOE_Identifying duplicates between lists_Opoutere

For the next 344 I’ll be staring at this:
DDOE_Identifying duplicates between lists_Excel
God, it’s good to be home.

A while back I answered this thread for someone wanting to identify any duplicate values found between 4 separate lists.

The way I understood the question, if something appears in each of the four lists, the Op wanted to know about it. If an item just appeared in 3 lists but not all 4, then they didn’t want it to be picked up. And the lists themselves might have duplicates within each list.

Say we’ve got these 4 lists:
DDOE_Identifying duplicates between lists_Names

We can’t simply use Conditional Formatting, because that will include duplicate names that don’t appear in each and every column, such as ‘Mike’:
DDOE_Identifying duplicates between lists_Wrong

Rather, we only want names that appear in every column:
DDOE_Identifying duplicates between lists_Right

I wrote a routine that handled any number of lists, using two dictionaries and a bit of shuffling between them. And the routine allows users to select either a contiguous range if their lists are all in one block, or multiple non-contiguous ranges if they aren’t.

  1. The user gets prompted for the range where they want the identified duplicates to appear:
    DDOE_Identifying duplicates between lists_Select Output Range
  2.  

  3. Then they get prompted to select the first list. The items within that list get added to Dic_A. (If they select more than one columns, the following steps get executed automatically).
    DDOE_Identifying duplicates between lists_Select First Range
  4.  

  5. Next they get prompted to select the 2nd list, at which point the code attempts to add each new item to Dic_A. If an item already exists in Dic_A then we know it’s a duplicate between lists, and so we add it to Dic_B. At the end of this, we clear Dic_A. Notice that any reference to selecting a contiguous range has been dropped from the InputBox:
    DDOE_Identifying duplicates between lists_Select 2nd range
  6.  

  7. When they select the 3rd list, then it attempts to add each new item to Dic_B, and if an error occurs, then we know it’s a duplicate between lists, and so we add it to Dic_A. At the end of this, we clear Dic_B. We carry on in this manner until the user pushes Cancel (and notice now that the InputBox message tells them to push cancel when they’re done):
    DDOE_Identifying duplicates between lists_Select 3rd range
  8.  

Pretty simple: just one input box, an intentional infinite loop, and two dictionaries that take turns holding the current list of dictionaries. Hours of fun.

Only problem is, I had forgotten to account for the fact that there might be duplicates within a list. The old code would have misinterpreted these duplicates as between-list duplicates, rather than within-list duplicates. The Op is probably completely unaware, and probably regularly bets the entire future of his country’s economy based on my bad code. Oops.

I’ve subsequently added another step where a 3rd dictionary is used to dedup the items in the list currently being processed. Here’s the revised code. My favorite line is the Do Until “Hell” = “Freezes Over” one.


Sub DuplicatesBetweenLists()

Dim rngOutput As Range
Dim dic_A As Object
Dim dic_B As Object
Dim dic_Output As Object
Dim lng As Long
Dim lngRange As Long
Dim varItems As Variant
Dim strMessage As String

varItems = False
On Error Resume Next
Set varItems = Application.InputBox _
(Title:="Select Output cell", _
Prompt:="Where do you want the duplicates to be output?", Type:=8)
If Err.Number = 0 Then 'user didn't push cancel
On Error GoTo 0
Set rngOutput = varItems
Set dic_A = CreateObject("Scripting.Dictionary")
Set dic_B = CreateObject("Scripting.Dictionary")
Set dic_Output = CreateObject("Scripting.Dictionary")

lngRange = 1
Do Until "Hell" = "Freezes Over" 'We only want to exit the loop once the user pushes Cancel,
' or if their initial selection was a 2D range
Select Case lngRange
Case 1: strMessage = vbNewLine & vbNewLine & "If your ranges form a contiguous block (i.e. the ranges are side-by-side), select the entire block."
Case 2: strMessage = ""
Case Else: strMessage = vbNewLine & vbNewLine & "If you have no more ranges to add, push Cancel"
End Select

varItems = Application.InputBox(Title:="Select " & lngRange & OrdinalSuffix(lngRange) & " range...", _
Prompt:="Select the " & lngRange & OrdinalSuffix(lngRange) & " range that you want to process." & strMessage, _
Type:=8)
If VarType(varItems) = vbBoolean Then
lngRange = lngRange - 1
If lngRange = 0 Then GoTo errhandler:
Exit Do
Else:
DuplicatesBetweenLists_AddToDictionary varItems, lngRange, dic_A, dic_B
If UBound(varItems, 2) > 1 Then
lngRange = lngRange - 1
Exit Do 'Data is in a contigous block
End If
End If
Loop

'Write any duplicate items back to the worksheet.
If lngRange Mod 2 = 0 Then
Set dic_Output = dic_B
Else: Set dic_Output = dic_A
End If

If dic_Output.Count > 0 Then
If dic_Output.Count < 65537 Then rngOutput.Resize(dic_Output.Count) = Application.Transpose(dic_Output.Items) Else 'The dictionary is too big to transfer to the workheet ' because Application.Transfer can't handle more than 65536 items. ' So we'll transfer it to an appropriately oriented variant array, ' then transfer that array to the worksheet WITHOUT application.transpose ReDim varOutput(1 To dic_Output.Count, 1 To 1) For lng = 1 To dic_Output.Count varOutput(lng, 1) = dic_Output.Item(lng) Next lng rngOutput.Resize(dic_Output.Count) = varOutput End If 'If dic_Output.Count < 65537 Then Else: MsgBox "There were no numbers common to all " & lngRange & " columns." End If 'If dic_Output.Count > 0 Then

End If 'If VarType(varItems) <> vbBoolean Then 'User didn't cancel

'Cleanup
Set dic_A = Nothing
Set dic_B = Nothing
Set dic_Output = Nothing

errhandler:

End Sub

Private Function DuplicatesBetweenLists_AddToDictionary(varItems As Variant, ByRef lngRange As Long, ByVal dic_A As Object, ByVal dic_B As Object)
Dim lng As Long
Dim dic_dedup As Object
Dim varItem As Variant
Dim lPass As Long
Set dic_dedup = CreateObject("Scripting.Dictionary")

For lPass = 1 To UBound(varItems, 2)

If lngRange = 1 Then
'First Pass: Just add the items to dic_A
For lng = 1 To UBound(varItems)
If Not dic_A.exists(varItems(lng, 1)) Then dic_A.Add varItems(lng, 1), varItems(lng, 1)
Next

Else:
' Add items from current pass to dic_Dedup so we can get rid of any duplicates within the column.
' Without this step, the code further below would think that intra-column duplicates were in fact
' duplicates ACROSS the columns processed to date

For lng = 1 To UBound(varItems)
If Not dic_dedup.exists(varItems(lng, lPass)) Then dic_dedup.Add varItems(lng, lPass), varItems(lng, lPass)
Next

'Find out which Dictionary currently contains our identified duplicate.
' This changes with each pass.
' * On the first pass, we add the first list to dic_A
' * On the 2nd pass, we attempt to add each new item to dic_A.
' If an item already exists in dic_A then we know it's a duplicate
' between lists, and so we add it to dic_B.
' When we've processed that list, we clear dic_A
' * On the 3rd pass, we attempt to add each new item to dic_B,
' to see if it matches any of the duplicates already identified.
' If an item already exists in dic_B then we know it's a duplicate
' across all the lists we've processed to date, and so we add it to dic_A.
' When we've processed that list, we clear dic_B
' * We keep on doing this until the user presses CANCEL.

If lngRange Mod 2 = 0 Then 'dic_A currently contains any duplicate items we've found in our passes to date
'Test if item appears in dic_A, and IF SO then add it to dic_B
For Each varItem In dic_dedup
If dic_A.exists(varItem) Then
If Not dic_B.exists(varItem) Then dic_B.Add varItem, varItem
End If
Next
dic_A.RemoveAll
dic_dedup.RemoveAll

Else 'dic_B currently contains any duplicate items we've found in our passes to date

'Test if item appear in dic_B, and IF SO then add it to dic_A
For Each varItem In dic_dedup
If dic_B.exists(varItem) Then
If Not dic_A.exists(varItem) Then dic_A.Add varItem, varItem
End If
Next
dic_B.RemoveAll
dic_dedup.RemoveAll
End If
End If
lngRange = lngRange + 1
Next

End Function

Function OrdinalSuffix(ByVal Num As Long) As String
'Code from http://www.cpearson.com/excel/ordinal.aspx

Dim N As Long
Const cSfx = "stndrdthththththth" ' 2 char suffixes
N = Num Mod 100
If ((Abs(N) >= 10) And (Abs(N) <= 19)) _ Or ((Abs(N) Mod 10) = 0) Then OrdinalSuffix = "th" Else OrdinalSuffix = Mid(cSfx, _ ((Abs(N) Mod 10) * 2) - 1, 2) End If End Function

Error Handling via an Error Class

A while ago I read an answer on stackoverflow about error handling. I can’t seem to find that question now, so you’ll have to take my word for it. The question was asking about error handling best practices in VBA and I found one of the answers interesting. The answerer said that you could use the Terminate event of a custom class module as your error logger. I had never thought of that.

I’ve been using the Professional Excel Development error handling method with great success for many years. This method controls the error as it moves back up the call stack, either by returning a Boolean to the calling procedure or by rethrowing the error. Without error handling, VBA sends the error back up the call stack automatically until it is handled. So, for instance, if you only handled errors in your entry point procedures, you would still have an error handler. You just wouldn’t have the information about the stack that would be critical to finding out where the error occurred.

The class method of error handling takes advantage of the built-in ability of VBA to pull an error back up the stack. It uses the fact that local variables go out of scope when the procedure is complete, such as when an unhandled error occurs and the cursor is sent to the calling procedure. If you had a local variable pointing to a class, that class’ Terminate event would fire when an unhandled error occurred.

Borrowing the setup from PED2, let’s see how this would work.

Sub EntryPoint()

Dim clsError As CError

On Error GoTo ErrorHandler

Set clsError = New CError: clsError.SetLoc "Module1", "EntryPoint"
SubProc1

ErrorExit:
Exit Sub

ErrorHandler:
If gbDebugMode Then
Stop: Resume
Else
Set clsError = Nothing
MsgBox Err.Description
Resume ErrorExit
End If

End Sub

Sub SubProc1()

Dim clsError As CError

Set clsError = New CError: clsError.SetLoc "Module1", "SubProc1"

SubProc2

End Sub

Sub SubProc2()

Dim clsError As CError

Set clsError = New CError: clsError.SetLoc "Module1", "SubProc2"

Debug.Print 1 / 0

End Sub

EntryPoint calls SubProc1. SubProc1 calls SubProc2. An error occurs in SubProc2. Only EntryPoint has error handling. It uses On Error Goto ErrorHandler to route program flow to the error handling section. Neither SubProc1 nor SubProc2 have any error handling. We’re going to let VBA kick the error back up to the call stack until it gets to EntryPoint.

Each procedure has a local variable that points to an instance of CError. CError is a custom class whose Terminate event I’ll be using to log the error as it moves back up the stack. When the error occurs in SubProc2, the clsError variable in SubProc2 goes out of scope and its Terminate event fires. The error is passed up to SubProc1 by VBA by design. Because there is no error handling in SubProc1, that error causes the instance of clsError in SubProc1 to go out of scope and its Terminate event fires.

Once again, VBA does it’s thing by passing control back up the stack, error in tow. EntryPoint does have error handling, so when program control reaches it, the ErrorHandler section goes into action. Assuming we’re not in debug mode, the first thing to do is terminate clsError by setting it to nothing. By the time we exit this procedure, the built-in Err object will have been reset and we won’t have anything to log. By setting clsError in EntryPoint to Nothing, we get the last entry in our log. After that, the error is displayed and program control is sent back to ErrorExit for any clean up (no clean up in this example, just the Exit Sub).

The log looks like this:

01 Jan 14 21:40:40 [errorclass2.xlsm]Module1.SubProc2, Error 11: Division by zero
01 Jan 14 21:40:40 [errorclass2.xlsm]Module1.SubProc1, Error 11: Division by zero
01 Jan 14 21:40:40 [errorclass2.xlsm]Module1.EntryPoint, Error 11: Division by zero

Of course I made it virtually identical to PED’s log entry.

Instead of putting error handling in all of the downstream procedures, I just put a local variable that will terminate when an error occurs. The class looks like this:

Private mlErrorID As Long
Private msProcedureName As String
Private msModuleName As String

Private Sub Class_Terminate()

If Err.Number > 0 Then
Debug.Print Format(Now, "dd mmm yy hh:mm:ss") & Space(1) & Me.Location & ", " & Me.ErrDescription
End If

End Sub
Public Property Let ModuleName(ByVal sModuleName As String): msModuleName = sModuleName: End Property
Public Property Get ModuleName() As String: ModuleName = msModuleName: End Property
Public Property Let ErrorID(ByVal lErrorID As Long): mlErrorID = lErrorID: End Property
Public Property Get ErrorID() As Long: ErrorID = mlErrorID: End Property
Public Property Let ProcedureName(ByVal sProcedureName As String): msProcedureName = sProcedureName: End Property
Public Property Get ProcedureName() As String: ProcedureName = msProcedureName: End Property

Public Sub SetLoc(ByVal sModule As String, ByVal sProc As String)

Me.ModuleName = sModule
Me.ProcedureName = sProc

End Sub

Public Property Get Location() As String

Location = "[" & ThisWorkbook.Name & "]" & Me.ModuleName & "." & Me.ProcedureName

End Property

Public Property Get ErrDescription() As String

ErrDescription = "Error " & Err.Number & ": " & Err.Description

End Property

I’ve kept the logging pretty simple for this example. In the Class_Terminate event, I first check to see if Err.Number is zero. This method relies on the fact that the Terminate event will fire when an error occurs. But in reality, the Terminate event will fire when the subprocedure finishes without error too. It fires whenever my local variable goes out of scope and that happens when there’s an error or when the subprocedure completes. We only want to log when an error occurs, so we have to check that.

The logging is a simple Debug.Print statement. To replicate the PED method, that would need to be expanded to write to a log file.

This is a very simple example that I put together to see how this might be setup. There might be some problems with this method that I haven’t encountered. I’m not advocating that you use this method, but I am intrigued by its simplicity. If you have any thoughts on this method of error handling or on error handling in general, leave a comment below.

You can download errorclass2.zip

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

Repeating Values in Pivot Tables

Often I’m using a PivotTable to aggregate some data to use elsewhere. I’ll take a PivotTable that looks like this

and make it look like a grid so that I can copy and paste it somewhere else. To do that, I first go to the PivotTable Options – Display tab and change it to Classic PivotTable layout.

Then I’ll go to each PivotItem that’s a row and remove the subtotal

and check the Repeat item labels checkbox.

And I get a PivotTable that’s ready for copying and pasting.

After about 50 times of doing that, I got sick of it. Now I just run this code.

Sub PivotGrid()

Dim pt As PivotTable
Dim pf As PivotField

On Error Resume Next
Set pt = ActiveCell.PivotTable
On Error GoTo 0

If Not pt Is Nothing Then
With pt
.InGridDropZones = True
.RowAxisLayout xlTabularRow
End With

For Each pf In pt.PivotFields
If pf.Orientation = xlRowField Then
pf.Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
pf.RepeatLabels = True
End If
Next pf
End If

End Sub

The Encyclopedia of Dictionaries

Frequent commenter snb has written a thorough page on the Scripting.Dictionary object. I resisted Dictionaries for the longest time, but lately I’ve been using them in almost every situation where I would have used a Collection object. Here’s the table of contents:

Contents
– What is a dictionary ?
– What is the purpose of a dictionary ?
– Where does the Dictionary derive from ?
– How to create a Dictionary ?
– How to populate a Dictionary ?
– Add or replace ?
– Keys
– When is a key unique ?
– Create unique keys automatically
– A list of unique elements
– Items
– The number of elements in a Dictionary
– Check the existence of a key / item in the Dictionary
– How to retrieve 1 element from the Dictionary ?
– How to use the array .Keys ?
– How to use the array .Items collection ?
– Change the key of an item
– Copy an item inside the Dictionary
– Remove an item from the Dictionary
– Adapt the contents of an item in the Dictionary
– Remove all items from the Dictionary
– Early binding and late binding
– Examples

If you use Dictionaries, you should bookmark this page. If not, you should start.