unpivot data using vba-CodePudding

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.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?

CodePudding user response：

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