求助将登记表的格式转换成显示表的格式

chlzj

工作表“登记”第一行是标题行，A列是姓名，B列是小计，C列是苹果，D列是香蕉，E列是梨子，F列是桔子，C至F列里的数据有部分是空的。工作表“显示”中第一行为标题行，A列为序号，B列为项目，C列为数量. 新建 Microsoft Excel 工作表.rar (8.01 KB, 下载次数: 7)

2024-10-4 12:19 上传

点击文件名下载附件

求助用VBA实现：遍历“登记”工作表中的数据，按照姓名进行分组处理，将第一个姓名所拥有的水果种类分别填到“显示”工作表的项目列（B列），对应的数量填到数量列（C列)，再将姓名填到项目（B列）最后一行，对应的小计填到数量（C列）最后一行，完成本组数据后，就在序号（A列）这几行中编制第一个顺序号，直到完成所有姓名的处理。

Qs18

1. Sub qs()
   
2. Dim arr, i
   
3. arr = Sheet1.Range("a1").CurrentRegion.Value
   
4. ReDim brr(1 To 10000, 1 To 3)
   
5. For i = 2 To UBound(arr)
   
6.     For c = 3 To UBound(arr, 2)
   
7.         If arr(i, c) <> Empty Then
   
8.             m = m + 1
   
9.             brr(m, 2) = arr(1, c): brr(m, 3) = arr(i, c)
   
10.             brr(m, 1) = i - 1
    
11.         End If
    
12.     Next c
    
13.         m = m + 1
    
14.         brr(m, 1) = i - 1
    
15.         brr(m, 2) = arr(i, 1): brr(m, 3) = arr(i, 2)
    
16. Next
    
17. Sheet2.Range("a2").Resize(m, 3) = brr
    
18. End Sub

复制代码

Qs18

试试............

Qs18

试试......

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, i&, j&, r&
   
    Application.ScreenUpdating = False
   
    ar = Worksheets(1).[A1].CurrentRegion.Value
    ReDim br(1 To UBound(ar) * UBound(ar, 2), 1 To 4)

    For i = 2 To UBound(ar)
        For j = 3 To UBound(ar, 2)
            If Len(ar(i, j)) Then
                r = r + 1
                br(r, 1) = i - 1
                br(r, 2) = ar(1, j)
                br(r, 3) = ar(i, j)
            End If
        Next j
        r = r + 1
        br(r, 1) = i - 1 '
        br(r, 2) = ar(i, 1)
        br(r, 3) = ar(i, 2)
    Next i
     
    Cells.Clear
    [A1].Resize(, 3) = Split("序号 项目 数量")
    [A2].Resize(r, UBound(br, 2)) = br
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

参与一下。。。

chlzj

Qs18 发表于 2024-10-4 13:34
试试......

感谢老师，您的代码好精简呀，我自己搞了很长一大堆，再次感谢！

chlzj

gwjkkkkk 发表于 2024-10-4 15:55
参与一下。。。

测试了一下，都能满足要求，我反应有点慢，得认真消化一下，感谢老师。