Results 1 to 5 of 5

Thread: Unpivot Columns in Excel

Threaded View

Previous Post Previous Post   Next Post Next Post
  1. #1
    Administrator Admin's Avatar
    Join Date
    Mar 2011
    Posts
    1,123
    Rep Power
    10

    Lightbulb Unpivot Columns in Excel

    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 !

    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
    Last edited by Admin; 12-08-2016 at 07:36 AM. Reason: code corrected
    Cheers !

    Excel Range to BBCode Table
    Use Social Networking Tools If You Like the Answers !

    Message to Cross Posters

    @ Home - Office 2010/2013/2016 on Win 10 (64 bit); @ Work - Office 2016 on Win 10 (64 bit)

Similar Threads

  1. Replies: 0
    Last Post: 03-27-2016, 02:26 AM
  2. Excel VBA to copy and paste columns
    By gripper in forum Excel Help
    Replies: 4
    Last Post: 04-15-2015, 06:03 PM
  3. Replies: 1
    Last Post: 01-19-2014, 04:45 PM
  4. Macro To Insert Columns In Excel
    By jac3130 in forum Excel Help
    Replies: 2
    Last Post: 05-17-2013, 07:49 AM
  5. Validating 2 Columns using excel VBA
    By freakszzy in forum Excel Help
    Replies: 2
    Last Post: 07-26-2012, 12:46 PM

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •