Archive for the ‘VBA’ Category.

Synchronising Slicers

Hi Everyone,

I’ve just added a new page to my site on how to synchronise slicers which point to different pivotcaches:
Synchronising Slicers

Enjoy the read!

Jan Karel Pieterse
www.jkp-ads.com

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) 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 'UNPIVOT' command in SQL Server (which is not available
'           in Excel)and writes the result directly to a PivotTable

'           Base code for the SQL UnPivot devived 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 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 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
        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()
    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
       
        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
           
    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 wksNew = Sheets.Add
            Set pt = objPivotCache.CreatePivotTable(TableDestination:=wksNew.Range("A3"))
            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.

Multiple Substitute UDF

Have you ever written this formula?

=SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(UPPER(A2),"AND","")," INC","")," LLC","")," LTD","")," DBA","")," ",""),".",""),",",""),"&",""),"-",""),"/",""),"'","")

I just did. It gets the job done, but it stinks. Here’s its replacement.

=subst(UPPER(A3),""," AND "," INC"," LLC"," LTD"," DBA"," CO"," ",".",",","&","-","/","'")

That’s a little better (assuming it works). On a side note, I wish Excel had built-in constants for formulas, so the above formula would look like this.

=subst(UPPER(A3),xlNULLSTRING," AND "," INC"," LLC"," LTD"," DBA"," CO",xlSPACE,".",xlCOMMA,"&","-","/",xlSINGLEQ)

Maybe I’ll create a Sheet template with those names defined. Or is that better in a Book template? Anyway, here’s the code for the poorly named Subst function.

Public Function Subst(text As String, NewText As String, ParamArray OldText() As Variant) As String
   
    Dim vItem As Variant
    Dim sReturn As String
    Dim vArray As Variant
   
    sReturn = text
   
    vArray = OldText
    BubbleSortLen vArray
   
    For Each vItem In vArray
        sReturn = Replace(sReturn, vItem, NewText, , , vbTextCompare)
    Next vItem
   
    Subst = sReturn
   
End Function

Public Sub BubbleSortLen(ByRef vArray As Variant)
   
    Dim i As Long, j As Long
    Dim sTemp As String
   
    For i = LBound(vArray) To UBound(vArray) - 1
        For j = i To UBound(vArray)
            If Len(vArray(j)) > Len(vArray(i)) Then
                sTemp = vArray(i)
                vArray(i) = vArray(j)
                vArray(j) = sTemp
            End If
        Next j
    Next i
   
End Sub

The ParamArray argument takes as many arguments as you want to throw at it. For some reason, I couldn’t pass OldText by reference to the sorting procedure, so I had to copy it to another variable first. I sort the terms by length so that “corporation” gets replace before “corp”. Otherwise, I’ll be left with “oration”, which is just silly.

Once sorted, I simply replace all of the old with the one new, and return the string. It worked well for the one application I’ve used it for and it was a heck of a lot easier to update. Thoughts?

A new tool: Trusted Document Manager

Hi everyone!

I have just published a new tool today, Trusted Document Manager. This little tool enables you to manage your list of trusted documents. Currently, Excel only allows you to either leave the list intact, or delete the entire list. This means all of your currently trusted documents become untrusted again so you have to enable macro’s on all of them once again. The tool allows you to remove just one file, remove an entire folder or even an entire drive. Also it offers to possibility to remove files which no longer exist from the list.

This is what the tool looks like:

ScreenshotOfTrustedDocManager

Enjoy!

Regards,

Jan Karel Pieterse
www.jkp-ads.com