excelvbaunpivot

unpivot data using vba


So I have this problem where if there is a value in a column, the row should be duplicated and copied to the next sheet. I will show a scenario to understand better.

This is sheet1

Sheet1

As you can see from the table above, there is a certain item name that doesn't have the three quantity columns. Some only have good quantity, some have both good and bad, and some have the three quantity. Now I want to copy this data to the other sheet with some modifications.

This should be the result in the next sheet:

Sheet2

As you can see, the data are duplicated based on the quantity columns if there is data or not. The status column is based on the quantity columns in sheet1. Status 0 is GOOD QTY, Status 1 is BAD QTY and Status 2 is VERY BAD QTY. This is my current code:

Set countsheet = ThisWorkbook.Sheets("Sheet1")
Set uploadsheet = ThisWorkbook.Sheets("Sheet2")

countsheet.Activate
countsheet.Range("B11", Range("F" & Rows.Count).End(xlUp)).Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
uploadsheet.Activate
uploadsheet.Range("B2").PasteSpecial xlPasteValues

I know this code only copies data from sheet1 to sheet2. How to modify this code and achieve the result above?


Solution

  • VBA Unpivot

    Option Explicit
    
    Sub UnpivotData()
        ' Needs the 'RefColumn' function.
        
        ' Source
        Const sName As String = "Sheet1"
        Const sFirstCellAddress As String = "B11" ' also Unique Column First Cell
        Const sAddCount = 1 ' Additional Column i.e. 'ITEM NAME'
        Const sAttrTitle As String = "STATUS"
        Const sAttrRepsList As String = "0,1,2" ' Attribute Replacements List
        Const sValueTitleAddress As String = "D10" ' i.e. QTY
        ' Destination
        Const dName As String = "Sheet2"
        Const dFirstCellAddress As String = "B2"
        ' Workbook
        Dim wb As Workbook: Set wb = ThisWorkbook
        
        ' Reference the first column range.
        Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
        Dim sfCell As Range: Set sfCell = sws.Range(sFirstCellAddress)
        Dim sfcrg As Range: Set sfcrg = RefColumn(sfCell)
        If sfcrg Is Nothing Then Exit Sub ' no data in the first (unique) column
        
        ' Reference the range and write it to an array.
        Dim sAttrReps() As String: sAttrReps = Split(sAttrRepsList, ",")
        Dim sAttrCount As Long: sAttrCount = UBound(sAttrReps) + 1
        Dim scUniqueCount As Long: scUniqueCount = 1 + sAddCount
        Dim scCount As Long: scCount = scUniqueCount + sAttrCount
        Dim srg As Range: Set srg = sfcrg.Resize(, scCount)
        Dim sData As Variant: sData = srg.Value
        
        ' Determine the destination size.
        Dim srCount As Long: srCount = srg.Rows.Count
        Dim svrg As Range
        Set svrg = srg.Resize(srCount - 1, sAttrCount) _
            .Offset(1, scUniqueCount)
        Dim drCount As Long: drCount = Application.Count(svrg) + 1
        Dim dcCount As Long: dcCount = scUniqueCount + 2
        Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
        
        ' Write the title row to the destination array.
        Dim scu As Long ' Unique Columns
        For scu = 1 To scUniqueCount
            dData(1, scu) = sData(1, scu) ' Unique
        Next scu
        dData(1, scu) = sAttrTitle ' Attributes
        dData(1, scu + 1) = sws.Range(sValueTitleAddress).Value ' Values
        
        ' Write the data rows to the destination array.
        Dim dr As Long: dr = 1 ' first row already written
        Dim sr As Long ' Rows
        Dim sca As Long ' Attribute Columns
        For sr = 2 To srCount ' first row already written
            For sca = 1 To sAttrCount
                If Len(CStr(sData(sr, sca + scUniqueCount))) > 0 Then
                    dr = dr + 1
                    For scu = 1 To scUniqueCount
                        dData(dr, scu) = sData(sr, scu) ' Unique
                    Next scu
                    dData(dr, scu) = sAttrReps(sca - 1) ' Attributes
                    dData(dr, scu + 1) = sData(sr, sca + scUniqueCount) ' Values
                End If
            Next sca
        Next sr
        
        ' Write the destination array to the destination range.
        Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
        Dim dfCell As Range: Set dfCell = dws.Range(dFirstCellAddress)
        Dim drg As Range: Set drg = dfCell.Resize(drCount, dcCount)
        drg.Value = dData
        
        ' Clear below the destination range.
        With drg
            Dim dcrg As Range
            Set dcrg = .Resize(dws.Rows.Count - .Row - drCount + 1).Offset(drCount)
            dcrg.Clear ' possibly just 'dcrg.ClearContents'
        End With
        
        MsgBox "Unpivot successful.", vbInformation, "Unpivot Data"
    
    End Sub
    
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Purpose:      Creates a reference to the one-column range from the first cell
    '               of a range ('FirstCell') to the bottom-most non-empty cell
    '               of the first cell's worksheet column.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Function RefColumn( _
        ByVal FirstCell As Range) _
    As Range
        If FirstCell Is Nothing Then Exit Function
        
        With FirstCell.Cells(1)
            Dim lCell As Range
            Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
                .Find("*", , xlFormulas, , , xlPrevious)
            If lCell Is Nothing Then Exit Function
            Set RefColumn = .Resize(lCell.Row - .Row + 1)
        End With
    
    End Function