将列添加到 VBA 循环

Question

我目前有下面的代码，它正在拉当前代码图像（每个集合的位置和#它正在添加动物），但是我想添加一个新列“颜色”并能够做到当前代码只对新列执行相同的操作（如代码图像的目标所示）。

我尝试添加以下内容，但我一直收到调试错误。

output(idx, 4) = items(itemIdx, 2)

如果有人能提供帮助，我将不胜感激！谢谢:)

当前代码

代码目标

Const SET_NAMES_ROW_START As Long = 6
Const SET_ITEMS_ROW_START As Long = 6
Const SET_NAMES_COL As String = "A"
Const SET_ITEMS_COL As String = "E"
Const OUTPUT_ROW_START As Long = 6
Const OUTPUT_COL As String = "G"

Dim names() As Variant, items() As Variant, output() As Variant
Dim namesCount As Long, itemsCount As Long
Dim idx As Long, nameIdx As Long, itemIdx As Long

'Read the set values.
With Sheet1
    names = .Range( _
                .Cells(SET_NAMES_ROW_START, SET_NAMES_COL), _
                .Cells(.Rows.Count, SET_NAMES_COL).End(xlUp)) _
               .Resize(, 2).Value2
    items = .Range( _
                .Cells(SET_ITEMS_ROW_START, SET_ITEMS_COL), _
                .Cells(.Rows.Count, SET_ITEMS_COL).End(xlUp)) _
               .Value2
End With

'Dimension the output array.
namesCount = UBound(names, 1)
itemsCount = UBound(items, 1)

ReDim output(1 To namesCount * itemsCount, 1 To 3)

'Populate the output array.
nameIdx = 1
itemIdx = 1
For idx = 1 To namesCount * itemsCount
    output(idx, 1) = names(nameIdx, 1)
    output(idx, 2) = names(nameIdx, 2)
    output(idx, 3) = items(itemIdx, 1)
    itemIdx = itemIdx + 1
    If itemIdx > itemsCount Then
        'Increment the name index by 1.
        nameIdx = nameIdx + 1
        'Reset the item index to 1.
        itemIdx = 1
    End If
Next

'Write array to the output sheet.
Sheet1.Cells(OUTPUT_ROW_START, OUTPUT_COL).Resize(UBound(output, 1), UBound(output, 2)).Value = output

Answer 1

有点逆向

' ***表示与的区别。

代码

Option Explicit

Sub SortOfUnpivot()
    
    Const FirstRow As Long = 6
    Const LastRowCol As String = "E"
    Const dstFirstCell As String = "H6"
    Dim srcCols As Variant
    srcCols = VBA.Array("A", "B", "E", "F") ' ***
    
    Dim LB As Long
    LB = LBound(srcCols)
    Dim UB As Long
    UB = UBound(srcCols)
    Dim srcCount As Long
    srcCount = UB - LB + 1
    
    Dim LastRow As Long
    LastRow = Cells(Rows.Count, LastRowCol).End(xlUp).Row
    Dim rng As Range
    Set rng = Cells(FirstRow, LastRowCol).Resize(LastRow - FirstRow + 1)
    Dim Source As Variant
    ReDim Source(LB To UB)
    
    Dim j As Long
    For j = LB To UB
        Source(j) = rng.Offset(, Columns(srcCols(j)).Column - rng.Column).Value
    Next j
    
    Dim UBS As Long
    UBS = UBound(Source(UB))
    
    Dim Dest As Variant
    ReDim Dest(1 To UBS ^ 2, 1 To srcCount)
    Dim i As Long
    Dim k As Long
    
    For j = 1 To UBS
        k = k + 1
        For i = 1 + (j - 1) * UBS To UBS + (j - 1) * UBS
            Dest(i, 1) = Source(0)(k, 1)
            Dest(i, 2) = Source(1)(k, 1)
            Dest(i, 3) = Source(2)(i - (j - 1) * UBS, 1)
            Dest(i, 4) = Source(3)(i - (j - 1) * UBS, 1) '***
        Next i
    Next j
    
    Range(dstFirstCell).Resize(UBound(Dest), srcCount).Value = Dest

End Sub

将列添加到 VBA 循环

Adding column to VBA loop

excel

vba

unpivot

有点逆向