使用 vba 逆透视数据

Question

所以我遇到了这个问题，如果列中有值，则应复制该行并复制到下一个 sheet。我将展示一个场景以更好地理解。

这是sheet1

从上面的table可以看出，有一个商品名称没有三个数量栏。有的只有好量，有的好坏兼备，有的三量。现在我想将此数据复制到另一个 sheet 并进行一些修改。

这应该是接下来的结果 sheet:

可以看到，无论有无数据，数据都是按照数量列重复的。状态列基于 sheet1 中的数量列。 Status 0 是 GOOD QTY，Status 1 是 BAD QTY，Status 2 是 VERY BAD QTY。这是我当前的代码：

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

我知道此代码仅将数据从 sheet1 复制到 sheet2。如何修改这段代码，达到上面的效果？

Answer 1

VBA 逆轴

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

使用 vba 逆透视数据

unpivot data using vba

excel

vba

unpivot

VBA 逆轴