Subtracting Cells in the Status Bar

Posted on February 10, 2014April 8, 2019 by Dick Kusleika

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

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

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)

1	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

Posted on January 11, 2014March 17, 2018 by Jeff Weir

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:

For the next 344 I’ll be staring at this:

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:

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’:

Rather, we only want names that appear in every column:

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.

The user gets prompted for the range where they want the identified duplicates to appear:

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).

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:

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):

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

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

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

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)

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)

'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

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

dic_B.RemoveAll

dic_dedup.RemoveAll

End If

lngRange = lngRange + 1

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

Posted on January 2, 2014January 20, 2018 by Dick Kusleika

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’s 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

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

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

Posted on November 21, 2013March 17, 2018 by Jeff Weir

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:

copies the specific contiguous or non-contiguous columns of data that the user want to turn into a flat file to a new sheet.
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.
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’.
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

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)

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

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

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

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

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

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

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

301

302

303

304

305

306

307

308

309

310

311

312

313

314

315

316

317

318

319

320

321

322

323

324

325

326

327

328

329

330

331

332

333

334

335

336

337

338

339

340

341

342

343

344

345

346

347

348

349

350

351

352

353

354

355

356

357

358

359

360

361

362

363

364

365

366

367

368

369

370

371

372

373

374

375

376

377

378

379

380

381

382

383

384

385

386

387

388

389

390

391

392

393

394

395

396

397

398

399

400

401

402

403

404

405

406

407

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

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)

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

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

Posted on November 12, 2013March 17, 2018 by Dick Kusleika

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

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

Posted on October 22, 2013October 24, 2013 by Dick Kusleika

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

Posted on October 10, 2013March 17, 2018 by Dick Kusleika

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

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

Posted on October 10, 2013October 10, 2013 by jkpieterse

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:

Enjoy!

Regards,

Jan Karel Pieterse
www.jkp-ads.com

Daily Dose of Excel

Haphazardly Posted Excel Information and Other Stuff

Category: VBA

Subtracting Cells in the Status Bar

Identifying duplicates between multiple lists

Error Handling via an Error Class

UnPivot Shootout

snb’s approach

Multiple Consolidation Trick approach

And the winner is…

Repeating Values in Pivot Tables

The Encyclopedia of Dictionaries

Multiple Substitute UDF

A new tool: Trusted Document Manager