Code:
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
Unpivot Columns in Excel
Reply With Quote
Bookmarks