unpivot data using vba

Question

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?

Answer 1

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

Answer 2

I found the easiest way is to use SQL (ADO) to unpivot a data range in Excel.

Sub unpivot_range()
    
    ' Establish connection
    Dim connection As Object
    Dim record_set As Object
    
    Set connection = CreateObject("ADODB.Connection")
    Set record_set = CreateObject("ADODB.Recordset")
    
    Dim sql As String
  
    ' Open connection
    With connection
        .ConnectionString = "Provider=Microsoft.ACE.OLEDB.16.0;" & _
            "Data Source=" & GetLocalPath(ThisWorkbook.Path) & "\" & ThisWorkbook.Name & _
            " ;Extended Properties=""Excel 12.0 Macro;HDR=YES"";"
        
        .Open
    End With
    
    
    ' Data range
    Set rng = Sheet1.Range("A2:E9")
    Let rng_str = "[" & rng.Worksheet.Name & "$" & Replace(rng.Address, "$", "") & "]"
    
    ' UNION query to achieve UNPIVOT
    Dim sql_arr() As String
    
    For c = 3 To rng.Columns.Count:
        sql_i = sql_i + 1
        ReDim Preserve sql_arr(1 To sql_i)
        status_col = rng.Item(1, c)
        sql = ""
        sql = sql & "SELECT [ITEM CODE], [ITEM NAME], " & c - 3 & " AS [STATUS], [" & status_col & "] AS [QTY]"
        sql = sql & " FROM " & rng_str
        sql_arr(sql_i) = sql
    Next c
    
    Let sql = Join(sql_arr, " UNION ALL ")
    Let sql = "SELECT * FROM ( " & sql & " ) "
    Let sql = sql & " WHERE [QTY] IS NOT NULL "
    Let sql = sql & " ORDER BY [ITEM CODE] ASC, [ITEM NAME] ASC "
    
    Set rs = connection.Execute(sql)

    ' Add headers
    For i = 0 To rs.Fields.Count - 1
        Sheet2.Range("A1").Cells(1, i + 1).Value = rs.Fields(i).Name
        Sheet2.Range("A1").Cells(1, i + 1).Font.Bold = True
    Next
    
    ' Add data
    Sheet2.Range("A2").CopyFromRecordset rs

End Sub