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


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:


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.Range("B11", Range("F" & Rows.Count).End(xlUp)).Select
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?


  • 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