将多组单元格附加到行底部

Question

我有一个已更改并添加到其中的电子表格，其中有一列类别和多个组，这些组在两列中具有相应的答案。这两列是“是/否”列，第二列是数量。

我一直在尝试将每个组放在下一个组的下方，以制作一个更容易排序和过滤的工作表，其中每个类别在第一列中重复，然后是每个组及其所需的数量。

我尝试复制两组列并循环遍历所有其他列。我无法在每个条目旁边填充类别。

Answer 1

Sub normalize()

   Dim ws1 As Worksheet, ws2 As Worksheet
   Dim j As Long, arCat, arData
   Dim lastrow As Long, lastcol As Long
   Dim grp As String, r As Long, n As Long
   
   Set ws1 = Sheets("Sheet3") ' before
   Set ws2 = Sheets("Sheet4") ' after
   ws2.Range("A1:D1") = Array("Categories", "Group", "Want", "Quantity")
   
   With ws1
        lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
        lastcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        arCat = .Range("A2:A" & lastrow).Value2
        n = UBound(arCat)
        r = 2
        
        For j = 2 To lastcol Step 2
            grp = .Cells(1, j)
            arData = .Cells(2, j).Resize(n, 2)
            
            ws2.Cells(r, 1).Resize(n) = arCat
            ws2.Cells(r, 2).Resize(n) = grp
            ws2.Cells(r, 3).Resize(n, 2) = arData
            
            r = r + n
        Next
    End With
      
End Sub

Answer 2

请测试下一种处理方式。即使对于更大的范围，使用两个数组，所有计算都在内存中完成，它应该非常快。处理结果在代码末尾立即被丢弃。它将结果放入另一张纸中。现在，它返回到下一张纸中，因此，如果您对其进行测试，请注意在活动纸页（要处理的）之后有一个空纸页：

Sub GroupCategories()
 Dim sh As Worksheet, sh1 As Worksheet, lastR As Long, lastcol As Long
 Dim arr, arrFin, i As Long, j As Long, k As Long
 
 Set sh = ActiveSheet
 Set sh1 = sh.Next 'use here your sheet where to return. Now, it returns in the next sheet
 
 lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
 lastcol = sh.cells(1, sh.Columns.count).End(xlToLeft).column

 arr = sh.Range("A1", sh.cells(lastR, lastcol)).Value2
 ReDim arrFin(1 To (UBound(arr) - 1) * (lastcol - 1) / 2 + 1, 1 To 4)

 'fill the header in the array:
 arrFin(1, 1) = "Categories": arrFin(1, 2) = "Group": arrFin(1, 3) = "Want": arrFin(1, 4) = "Quantity"
 k = 2 'initialixe the variable keeping the array row
 
 For i = 2 To UBound(arr, 2) Step 2
    For j = 1 To UBound(arr) - 1
        arrFin(k, 1) = arr(j + 1, 1): arrFin(k, 2) = arr(1, i)
        arrFin(k, 3) = arr(j + 1, i): arrFin(k, 4) = arr(j + 1, i + 1)
        k = k + 1
    Next j
 Next i
 
 'drop the procesed array result at once and format a little:
 With sh1.Range("A1").Resize(UBound(arrFin), 4)
    .Value2 = arrFin
    .rows(1).Font.Bold = True
    .EntireColumn.AutoFit
 End With
 
 MsgBox "Ready...": sh1.Activate
End Sub

Answer 3

堆叠数据组（Excel 公式）

=LET(Table,A1:M5,dCols,2,
    Data,DROP(Table,1),dRows,ROWS(Data),drSeq,SEQUENCE(dRows),
    hData,DROP(TAKE(Table,1),,1),hrSeq,SEQUENCE(dRows,,1,0),
    sData,TAKE(Data,,1),dData,DROP(Data,,1),
    rcSeq,SEQUENCE(COLUMNS(dData)/dCols),
DROP(REDUCE("",rcSeq,LAMBDA(rRes,rc,LET(cc,dCols*rc-dCols+1,
    VSTACK(rRes,HSTACK(sData,INDEX(hData,hrSeq,cc),
        INDEX(dData,drSeq,SEQUENCE(,dCols,cc))))))),1))

编辑

• 这是一个很长的公式，在工作表中使用它有点笨拙。因此你应该用它创建一个 lambda 函数。
• 选择

  Ribbon->Formulas->Defined Names->Define Name

  并在

  Name:

  文本框中输入名称，例如

  VStackGroups

  ，然后在

  Refers to:

  文本框中输入以下公式：

=LAMBDA(Table,DataColumns,LET(
    Data,DROP(Table,1),dRows,ROWS(Data),drSeq,SEQUENCE(dRows),
    hData,DROP(TAKE(Table,1),,1),hrSeq,SEQUENCE(dRows,,1,0),
    sData,TAKE(Data,,1),dData,DROP(Data,,1),
    rcSeq,SEQUENCE(COLUMNS(dData)/DataColumns),
DROP(REDUCE("",rcSeq,LAMBDA(rRes,rc,LET(cc,DataColumns*rc-DataColumns+1,
    VSTACK(rRes,HSTACK(sData,INDEX(hData,hrSeq,cc),
        INDEX(dData,drSeq,SEQUENCE(,DataColumns,cc))))))),1)))

• 现在您可以使用该功能，例如用一个简单的

  =VStackGroups(A1:M5,2)
  

  您可以在工作簿中的任何位置使用不同的数据进行操作。

更多...

• 当然，这是一个很酷的公式。不幸的是，您无法继续玩，即您无法“过滤和排序”溢出公式的数据。
• 因此，创建名称后，您可以使用一些简单的 VBA 编写公式并将其转换为值：

Sub StackGroups()
    
    Const SRC_NAME As String = "Sheet1"
    Const SRC_DATA_COLUMNS As Long = 2
    Const DST_NAME As String = "Sheet2"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_NAME)
    Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
    
    ' Destination
    Dim dws As Worksheet: Set dws = wb.Sheets(DST_NAME)
    
    Dim dfCell As Range
    
    With dws.Range("A1").CurrentRegion
        ' Clear previous data.
        .Resize(.Rows.Count - 1).Offset(1).ClearContents ' preserve headers
        ' Reference the first destination cell.
        Set dfCell = .Columns(1).Cells(2)
    End With
    
    ' Write formula.
    dfCell.Formula2 = "=VStackGroups('" & SRC_NAME & "'!" _
        & srg.Address & "," & SRC_DATA_COLUMNS & ")"
    
    ' Convert formula to values.
    With dws.Range("A1").CurrentRegion ' it's not the same as the previous one
        With .Resize(.Rows.Count - 1).Offset(1)
            .Value = .Value
        End With
    End With
    
End Sub

• 总而言之，也许（当然）首先使用 VBA 是更好的方法。这只是为了提供替代方案并展示使用新的 Excel 函数可以实现什么。