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:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 |
Sub M_snb() sn = Cells(1).CurrentRegion x = Cells(1).CurrentRegion.Rows(1).SpecialCells(2).Count y = UBound(sn, 2) - x ReDim sp(1 To x * (UBound(sn) - 1), 1 To 4) For j = 1 To UBound(sp) m = (j - 1) Mod (UBound(sn) - 1) + 2 n = (j - 1) \ (UBound(sn) - 1) + y + 1 sp(j, 1) = sn(m, 1) sp(j, 2) = sn(m, 2) sp(j, 3) = sn(1, n) sp(j, 4) = sn(m, n) Next Cells(20, 1).Resize(UBound(sp), UBound(sp, 2)) = sp End Sub |
…which I’m sure you’ll all agree falls somewhere on the spectrum between good looking and positivity anorexic. So I put a bit of meat on it’s bones so that it prompts you for ranges and handles any sized cross-tab:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 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:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 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 Next Set wksTempCrosstab = Worksheets.Add wksTempCrosstab.Name = "TempCrosstab" 'Copy data to the temp worksheet "TempCrosstab" rngLeftHeaders.Copy wksTempCrosstab.[A1] Set rngLeftHeaders = wksTempCrosstab.[A1].CurrentRegion rngLeftHeaders.Name = "TempCrosstab!appRowFields" rngRightHeaders.Copy wksTempCrosstab.[A1].Offset(0, rngLeftHeaders.Columns.Count) Set rngRightHeaders = wksTempCrosstab.[A1].Resize(rngRightHeaders.Rows.Count, rngRightHeaders.Columns.Count) rngRightHeaders.Name = "TempCrosstab!appCrosstabFields" 'Work out if the worksheet has enough rows to fit a crosstab in If rngRightHeaders.CurrentRegion.Count > Columns(1).Rows.Count Then Err.Raise 998 varRowHeadings = rngLeftHeaders.Value ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 'Part Two: ' 'Construct a new pipe-delimited column out of the columns that run down the ' 'left of the crosstab, and then delete the original columns used to do this ' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' strFormula = "=RC[1]" strConcat = "&""|""&" iColumns = Range("TempCrosstab!appRowFields").Columns.Count For iCount = 2 To iColumns strCell = "RC[" & iCount & "]" strFormula = strFormula & strConcat & strCell Next iCount With Worksheets("TempCrosstab") .Columns("A:A").Insert Shift:=xlToRight iRows = Intersect(Worksheets("TempCrosstab").Columns(2), Worksheets("TempCrosstab").UsedRange).Rows.Count .Range("A2:A" & iRows).FormulaR1C1 = strFormula .Range("A2:A" & iRows).Value = .Range("A2:A" & iRows).Value .Range("appRowFields").Delete Shift:=xlToLeft End With Names("TempCrosstab!appRowFields").Delete ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 'Part Three: ' 'Use data to create a pivot table using "Multiple Consolidation Ranges" option, ' 'which has the side benefit of providing a vertical extract once you double ' 'click on the Grand Total field ' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Set rngInputData = Worksheets("TempCrosstab").[A2].CurrentRegion rngInputData.Name = "SourceData" 'Find out the number of columns contained within the primary key iKeyColumns = Len([SourceData].Cells(2, 1).Value) - Len(Replace([SourceData].Cells(2, 1).Value, "|", "")) + 1 ' Create the intermediate pivot from which to extract flat file Set pc = ActiveWorkbook.PivotCaches.Add(SourceType:=xlConsolidation, SourceData:=Array("=sourcedata", "Item1")) Set wksPT = Worksheets.Add Set pt = wksPT.PivotTables.Add(PivotCache:=pc, TableDestination:=[A3]) ' Get address of PT Total field, then double click it to get underlying records Set rngPTData = pt.DataBodyRange lPT_Rows = rngPTData.Rows.Count iPT_Columns = rngPTData.Columns.Count Set rngPT_GrandTotal = rngPTData.Cells(1).Offset(lPT_Rows - 1, iPT_Columns - 1) rngPTData.Cells(1).Offset(lPT_Rows - 1, iPT_Columns - 1).Select Selection.ShowDetail = True Set wksFlatFile = ActiveSheet ' Delete current "Flat_File" worksheet if it exists, name current sheet "Flat_File" On Error Resume Next Sheets("Flat_File").Delete On Error GoTo 0 wksFlatFile.Name = "Flat_File" ' Delete unneeded column and the now-unneeded TempCrosstab and wksPT worksheets Columns(4).Delete Shift:=xlToLeft wksPT.Delete Worksheets("TempCrosstab").Delete '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 'Part Four: ' 'split our pipe-delimited column back into seperate columns, using Excel's ' 'Text-to-Column funcionality. ' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Set rngKeyFormula = Worksheets("Flat_File").Range("A2") rngKeyFormula.Name = "appKeyFormula" 'Find out the number of columns contained within the primary key iKeyColumns = Len([appKeyFormula].Cells(2, 1).Value) - Len(Replace([appKeyFormula].Cells(2, 1).Value, "|", "")) + 1 'Insert columns to the left that we will unpack the Unique Key to [B1].Resize(, iKeyColumns).EntireColumn.Insert 'Split the Unique Key column into its constituent parts, 'using Excel's Text-to-Columns functionality Worksheets("Flat_File").Columns("A:A").Select Selection.TextToColumns Destination:=Range("b1"), DataType:=xlDelimited, _ ConsecutiveDelimiter:=False, Other:=True, OtherChar:="|" 'Delete old composite key, add original column headers [A1].EntireColumn.Delete Set rngRowHeaders = [A1].Resize(1, iKeyColumns) rngRowHeaders.Value = varRowHeadings 'Add new column header with crosstab data name [A1].Offset(0, iKeyColumns).Value = strCrosstabName Selection.CurrentRegion.Columns.AutoFit Worksheets("Flat_File").Select errhandler: If Err.Number <> 0 Then Dim strErrMsg As String Select Case Err.Number Case 999: 'User pushed cancel. Do nothing Case 998 'Worksheet does not have enough rows to hold flat file strErrMsg = "Oops, there's not enough rows in the worsheet to hold a flatfile of all the data you have selected. " strErrMsg = strErrMsg & vbNewLine & vbNewLine strErrMsg = strErrMsg & "Your dataset will take up " & Format(rngRightHeaders.CurrentRegion.Count, "#,##0") & " rows of data " strErrMsg = strErrMsg & "but your worksheet only allows " & Format(Application.Range("A:A").Count, "#,##0") & " rows of data. " strErrMsg = strErrMsg & vbNewLine & vbNewLine MsgBox strErrMsg Case Else MsgBox Err.Description, vbCritical, "UnPivotByConsolidation" End Select End If With Application .ScreenUpdating = True .DisplayAlerts = True End With End Function |
The SQL appoach is the same as I published here.
And the winner is…
…snb. By a long shot. With the ever-so-slight caveat that you’re crosstabs are not so stupidly fat that the resulting flat file exceeds the number of rows in Excel.
Here’s how things stacked up on a 53 Column x 2146 Row crosstab, which gives a 117,738 row flat-file:
| Approach | Time (M:SS) |
|---|---|
| snb | 0:01 |
| UnPivotByConsolidation | 0:04 |
| UnPivotBySQL | 0:14 |
And here’s how things stacked up on a 53 Columns x 19,780 Row crosstab, giving a 1,048,340 row flat-file (i.e. practically the biggest sized crosstab that you can unwind):
| Approach | Time (M:SS) |
|---|---|
| snb | 0:19 |
| UnPivotByConsolidation | 0:42 |
| UnPivotBySQL | 2:17 |
So there you have it. Use snb’s code. Unless you have no choice but to use my longer, slower SQL approach.
—Update 26 November 2013—
It was remiss of me not to mention the Data Normalizer routine in Doug Glancy’s great yoursumbuddy blog, which is just about as fast as snb’s approach below. Go check it out, and subscribe to Doug’s blog while you’re there if you haven’t already.
—
If you don’t want the hassle of working out which to use, here’s a routine that uses snb’s if possible, and otherwise uses mine:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 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 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 |