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