Option Explicit
Public Declare Function timeGetTime Lib "winmm.dll" () As Long
Sub UnPivotBySQL()
' Description: Turns a crosstab file into a flatfile (equivalent to the 'UNPIVOT' command in SQL Server)
' and makes a pivottable out of it. Basically it rotates columns of a table-valued expression
' into column values. Base code from Fazza at MR EXCEL forum:
' http://www.mrexcel.com/forum/showthread.php?315768-Creating-a-pivot-table-with-multiple-sheets
' Programmer: Jeff Weir
' Contact: weir.jeff@gmail.com or heavydutydata@gmail.com
' Date? Who? Modification?
' 31/07/2012 JSW Initial modification of Fazza's code
' 1/8/2012 JSW Changed Connection String -
' ...from:
' "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=", wksSource.Parent.FullName , ";Extended Properties=""Excel 8.0;"""
' ...to:
' "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=", wksSource.Parent.FullName , ";Extended Properties=""Excel 12.0;"""
' ...because old string could not handle new file formats
' Inputs: No arguments, but user selects input ranges ranges and enters ranges
' containing column names via application.inputbox
' 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
' Base code from Fazza at MR EXCEL:
' http://www.mrexcel.com/forum/showthread.php?315768-Creating-a-pivot-table-with-multiple-sheets
' Fazza's code base was perfect for this, given that:
' A) unwinding a crosstab requires heavy use of 'UNION ALL' in absence of an 'UNPIVOT' command,
' B) The Microsoft JET 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.
' C) unwinding a BIG crosstab by using the 'reverse pivot' trick via multiple consolidation ranges
' might well result in more data that the worksheet can handle.
'
'Observations:
' 1. ADODB doesn't seem to like non-strings in columns, e.g. it would give the error message
' "No value given for one or more required parameters". So to process columns with dates or integers
' I temporarily convert any numerical columns to strings by putting an apostrophe in front of any such
' headers with this line: If IsNumeric(rng) Then rng.Value = "'" & rng.Value
'
' 2. If you run the code, then change any of the headers and then run the code again, you'll get the same
' error "No value given for one or more required parameters" that you get in the non-strings case
' mentioned above. I guess it's because we're querying an open workbook. I haven't (yet) tried to save
' a temp copy of the workbook somewhere, closing it, then querying it to see if that makes any difference.
' To work around this, create a new workbook, copy your crosstab to that, save it, and run the code.
'
' 3. I tried to use selection.currentregion as a default in my first inputbox that prompts users for the range
' containing the crosstab, but for some reason it just brings up the value of the first cell in the
' currentregion, and not the address. Not sure why, so I took it out.
'
' 4. After the pivot is created, if you drag the aggregated field from the Values area to the Row Labels area
' (i.e. change it from .Orientation = xldata field to .Orientation = xlrowfield) , for some reason the
' pivottable looks like it is completely empty. But if you click on a dropdown, you'll see that there
' are in fact values in there. And if you drag the aggregated field back, then double click on the grand
' total, then it will spit out all the underlying data into a new sheet. So it's very strange that you can't
' see anything when all fields are rowfields.
Const lngMAX_UNIONS As Long = 25
Const bDebugMode As Boolean = False
Dim i As Long, j As Long
Dim arSQL() As String
Dim arTemp() As String
Dim objPivotCache As PivotCache
Dim objRS As Object
Dim wksNew As Worksheet
Dim rngCrosstab As Range
Dim cell As Range
Dim rngLeftHeaders As Range
Dim rngRightHeaders As Range
Dim strCrosstabName As String
Dim strLeftHeaders As String
Dim wksSource As Worksheet
Dim rngRecordSet As Range
Dim pt As PivotTable
Dim rngCurrentHeader As Range
Dim bUserDefaults As Boolean
Dim lStartTime As Long
Dim lEndTime As Long
If ActiveWorkbook.Path <> "" Then 'can only proceed if the workbook has been saved somewhere
On Error Resume Next
Range("app_UseDefaults").Select 'check to see if the workbook has a 'default settings' mode
If Err.Number = 0 Then ' the workbook has a 'default settings' mode
bUserDefaults = [app_UseDefaults] 'if the range app_UseDefault contains the word TRUE, then default values stored in the workbook will be used
End If
On Error GoTo 0
If bUserDefaults Then 'UseDefaults' workbook setting is set to TRUE, so code should use the default settings stored in the workbook
Set rngCrosstab = Range([app_rngCrosstab])
Set rngLeftHeaders = Range([app_rngLeftHeaders])
Set rngRightHeaders = Range([app_rngRightHeaders])
strCrosstabName = [app_strCrosstabName]
Else: 'UseDefaults' workbook setting is set to FALSE, so we have to get values from the user
'Identify where the ENTIRE crosstab table is
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)
rngCrosstab.Cells(1, 1).Select 'Returns them to the top left of the source table for convenience
'Identify range containing columns of interest running down the table
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 " _
, Type:=8)
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
'Identify range containing data and cross-tab headers running across the table
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)
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
'Get the field name for the columns being consolidated e.g. 'Date' or 'Country' or 'Project'
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. 'DatePeriod', 'Country' or 'Project'" _
, Default:="DatePeriod", Type:=2)
End If
Application.ScreenUpdating = False
lStartTime = timeGetTime
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
'NOTE: for some reason this doesn't work for Excel table headers
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)
Set objRS = CreateObject("ADODB.Recordset")
objRS.Open Join$(arSQL, vbCr & "UNION ALL" & vbCr), _
Join$(Array("Provider=Microsoft.ACE.OLEDB.12.0; Data Source=", _
wksSource.Parent.FullName, ";Extended Properties=""Excel 12.0;"""), vbNullString)
Set objPivotCache = ActiveWorkbook.PivotCaches.Add(xlExternal)
Set objPivotCache.Recordset = objRS
Set objRS = Nothing
Set wksNew = Sheets.Add
Set pt = objPivotCache.CreatePivotTable(TableDestination:=wksNew.Range("A3"))
Set objPivotCache = Nothing
'Turn any numerical headings back to numbers by effectively removing any apostrophes in front
For Each cell In rngLeftHeaders
If IsNumeric(cell) Or IsDate(cell) Then cell.Value = cell.Value
Next cell
For Each cell In rngRightHeaders
If IsNumeric(cell) Or IsDate(cell) Then cell.Value = cell.Value
Next cell
With pt
.ManualUpdate = True 'stops the pt refreshing while we make chages to it.
.RepeatAllLabels xlRepeatLabels
For Each cell In rngLeftHeaders
With .PivotFields(cell.Value)
.Orientation = xlRowField
.Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
End With
Next cell
With .PivotFields(strCrosstabName)
.Orientation = xlRowField
.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
lEndTime = timeGetTime
Debug.Print "Time taken: " & lEndTime - lStartTime & "Milliseconds"
Application.ScreenUpdating = True
Else: MsgBox "You must first save the workbook for this code to work."
End If
End Sub
