Unpivot Columns in Excel

[Admin]

Hi

I saw this feature in Power BI where you can select the columns and simply click unpivot and you are done. Thought it would be nice if we have this feature in Excel as well !

Comments and feedback are welcome !


Option Explicit
Private Const MsgBoxTitle As String = "Unpivot Columns"


Sub UnPivotColumns()

Dim Data As Variant
Dim UPColumns As Variant
Dim Unpivot() As Variant
Dim vMatch As Variant
Dim vItem As Variant

Dim r As Long
Dim c As Long
Dim Counter As Long
Dim UB1 As Long
Dim UB2 As Long
Dim ArrSize1 As Long
Dim UPCols() As Long
Dim FixedCols() As Long
Dim SCol As Long
Dim j As Long
Dim ArrSize2 As Long
Dim i As Long
Dim StartRow As Long
Dim ArrCount As Long

Dim Addr As String
Dim UPAddress As String
Dim ShtName As String

Dim rngData As Range
Dim rngUnpivot As Range
Dim rngArea As Range
Dim rngCell As Range

Dim wksUnpivot As Worksheet

Addr = ActiveSheet.UsedRange.Address

On Error Resume Next
Set rngData = Application.InputBox("Select the data range(including column header).", MsgBoxTitle, Addr, , , , , 8)
Err.Clear: On Error GoTo 0

If rngData Is Nothing Then
MsgBox "You either clicked cancel or it's an invalid range. Please try again.", vbExclamation, MsgBoxTitle
GoTo Xit
End If

If Application.WorksheetFunction.CountA(rngData) = 0 Then
MsgBox "There is no data in the selection.", vbExclamation, "Unpivot Columns"
Exit Sub
End If

On Error Resume Next
UPAddress = Intersect(rngData, rngData.SpecialCells(xlCellTypeConstants, 1)).Offset(-1).Rows(1).Address
Err.Clear: On Error GoTo 0

On Error Resume Next
Set rngUnpivot = Application.InputBox("Select the unpivot data range(only column header).", MsgBoxTitle, UPAddress, , , , , 8)
Err.Clear: On Error GoTo 0

If rngUnpivot Is Nothing Then
MsgBox "You either clicked cancel or it's an invalid range. Please try again.", vbExclamation, MsgBoxTitle
GoTo Xit
End If

If Application.WorksheetFunction.CountA(rngUnpivot) = 0 Then
MsgBox "There is no data in the selection.", vbExclamation, MsgBoxTitle
Exit Sub
End If

Application.ScreenUpdating = 0

Data = rngData.Value

UB1 = UBound(Data, 1)
UB2 = UBound(Data, 2)

ReDim UPCols(1 To UB2)

SCol = rngData.Column

With rngUnpivot
Addr = .Address
For Each vItem In Split(Addr, Application.International(xlListSeparator))
Set rngArea = .Parent.Range(vItem).Rows(1).Cells
For Each rngCell In rngArea
If Intersect(rngData, rngCell) Is Nothing Then
MsgBox "Mismatch in Unpivot columns selection", vbExclamation, MsgBoxTitle
GoTo Xit
End If
Counter = Counter + 1
UPCols(Counter) = SCol + rngCell.Column - 1
Next
Next
ReDim Preserve UPCols(1 To Counter)
End With

ArrSize1 = 1 + ((UB1 - 1) * Counter)

ReDim FixedCols(1 To UB2)

'**************************** Out of memory error variable ************************************
ArrSize2 = 300000 '<<< keep change this # to a lower number until the error goes :(
'************************************************* *********************************************
On Error GoTo OoMErr
If ArrSize1 > ArrSize2 Then
ReDim Unpivot(1 To ArrSize2, 1 To UB2)
Else
ReDim Unpivot(1 To ArrSize1, 1 To UB2)
End If
Err.Clear: On Error GoTo 0

Counter = 0

If Not UB2 = UBound(UPCols) Then
For c = 1 To UB2
vMatch = Application.Match(c, UPCols, 0)
If IsError(vMatch) Then
Counter = Counter + 1
FixedCols(Counter) = c
Unpivot(1, Counter) = Data(1, c)
End If
Next
UB2 = Counter + 2
Else
For c = 1 To UB2
FixedCols(c) = c
Unpivot(1, c) = Data(1, c)
Next
End If

If Counter Then
ReDim Preserve FixedCols(1 To Counter)
End If

If ArrSize1 > ArrSize2 Then
ReDim Preserve Unpivot(1 To ArrSize2, 1 To UB2)
Else
ReDim Preserve Unpivot(1 To ArrSize1, 1 To UB2)
End If

If Not UB2 = UBound(UPCols) Then
Unpivot(1, UB2 - 1) = "Attribute"
Unpivot(1, UB2) = "Value"
End If

If ArrSize1 > ArrSize2 Then
StartRow = 2
ArrCount = 1 + (ArrSize1 \ ArrSize2)
Counter = 1
For i = 1 To ArrCount
StartAgain:
If i > 1 Then
Counter = 0
ReDim Unpivot(1 To ArrSize2, 1 To UB2)
End If
Application.StatusBar = "Unpivoting...." & Format(i / ArrCount, "0%")
ShtName = IIf(i = 1, "UnpivotData", "UnpivotData" & i - 1)
For r = StartRow To UB1
For c = 1 To UBound(UPCols)
Counter = Counter + 1
For j = 1 To UBound(FixedCols)
Unpivot(Counter, j) = Data(r, FixedCols(j))
Next
If Not UB2 = UBound(UPCols) Then
Unpivot(Counter, UB2 - 1) = Data(1, UPCols(c))
Unpivot(Counter, UB2) = Data(r, UPCols(c))
End If
Next
If Counter > (ArrSize2 - UBound(UPCols)) Then
StartRow = r + 1
i = i + 1
GoTo UnPvt
End If
Next
Next
Else
ShtName = "UnpivotData"
Counter = 1
For r = 2 To UB1
For c = 1 To UBound(UPCols)
Counter = Counter + 1
For j = 1 To UBound(FixedCols)
Unpivot(Counter, j) = Data(r, FixedCols(j))
Next
If Not UB2 = UBound(UPCols) Then
Unpivot(Counter, UB2 - 1) = Data(1, UPCols(c))
Unpivot(Counter, UB2) = Data(r, UPCols(c))
End If
Next
Next
End If
UnPvt:
If Counter Then
On Error Resume Next
Set wksUnpivot = Nothing
Set wksUnpivot = ThisWorkbook.Worksheets(ShtName)
Err.Clear: On Error GoTo 0
If wksUnpivot Is Nothing Then
ThisWorkbook.Worksheets.Add
Set wksUnpivot = ActiveSheet
wksUnpivot.Name = ShtName
End If

With wksUnpivot
.UsedRange.Clear
If i And i <= 2 Then
.Range("a1").Resize(Counter, UB2).Value = Unpivot
Else
.Range("a1").Resize(, UB2).Value = ThisWorkbook.Worksheets(Replace(ShtName, i - 2, "")).Range("a1").Resize(, UB2).Value
.Range("a2").Resize(Counter, UB2).Value = Unpivot
End If
End With
If i And i <= ArrCount Then
GoTo StartAgain
End If
End If

MsgBox "It's Done!" & vbLf & vbLf & vbLf & vbLf & vbLf & vbTab & vbTab & "-- Admin@ExcelFox", vbInformation, MsgBoxTitle

Xit:
Application.ScreenUpdating = 1
Application.StatusBar = False
Exit Sub

OoMErr:
If Err.Description = "Out of memory" Then
MsgBox "System gives 'Out of memory' error." & vbLf & "Change the variable to a lower number from the current # " & ArrSize2 & vbLf & "and try again", vbExclamation, MsgBoxTitle
Else
MsgBox "Err # : " & Err.Number & vbLf & Err.Description, vbCritical, MsgBoxTitle
End If
GoTo Xit

End Sub

[jomili]

Tried to give it a whirl but no go. I've attached my pivot so we can understand each other. For "Select the data range(including column header)" I take that to mean D1:I64. But when it says "Select the unpivot data range(only column header)." I have no idea what it's asking for. My best guess is to select only A1:I1, but that doesn't work.

[Admin]

But when it says "Select the unpivot data range(only column header)." I have no idea what it's asking for. My best guess is to select only A1:I1, but that doesn't work.

That will be your unpivot column range which is D1:I1

HTH

[jomili]

Thanks. Now I've got it straight. For "Select the data range(including column header)" that means A1:I64, IE the whole table, and for "Select the unpivot data range(only column header)" I'd select the column headers over the columns containing the numerical values.

The macro works quick and well, so I'm planning on adding it to my list of tools. But I'll change the selection messages to "Select the table, including column headers", and "Select just the column headers over the numerical data." Those messages make more sense to me.

Thanks for developing this!

[jomili]

issue: I put it into my PERSONAL, but in running it I got a "Subscript out of Range" at this line:
.Range("a1").Resize(, UB2).Value = ThisWorkbook.Worksheets(Replace(ShtName, i - 2, "")).Range("a1").Resize(, UB2).Value. I got around that by changing "ThisWorkbook" to "ActiveWorkbook", and that seemed to fix the problem.

Whoops, there were 2 more instances of "ThisWorkbook" that I had to change to "ActiveWorkbook"