[已解决]实现类似分类汇总的效果

zhangchenld

各位老师：
  将sheet2中的明细，分类转置移动到sheet1中。明细中的种类数量不确定，移动需要去重，附件为示例，请教各位老师，感谢。
sheet1

姓名	型号1	型号2	型号3	型号4	型号5	型号6	型号7	型号8	型号9
张三	产品1	产品2
李四	产品1	产品3	产品5
王五	产品1	产品2
赵六	产品1	产品2
刘七	产品2	产品7	产品8	产品3

sheet2

姓名	型号
张三	产品1
张三	产品2
李四	产品1
李四	产品1
李四	产品3
李四	产品5
王五	产品1
王五	产品2
赵六	产品1
赵六	产品1
赵六	产品2
刘七	产品2
刘七	产品2
刘七	产品7
刘七	产品8
刘七	产品3

最佳答案

月排行榜 / 总排行榜

林木水

2022-2-16 18:49

1. Sub text()
   
2. Dim i As Integer, j As Integer, arr, brr, crr(1 To 10000, 1 To 2), k As Integer
   
3. arr = Sheet1.Range("b2:j6")
   
4. brr = Sheet1.Range("a2:a6")
   
5. For i = 1 To UBound(brr)
   
6. For j = 1 To UBound(arr, 2)
   
7. If arr(i, j) = "" Then
   
8. Else
   
9. k = k + 1
   
10. crr(k, 1) = brr(i, 1)
    
11. crr(k, 2) = arr(i, j)
    
12. End If
    
13. Next j
    
14. Next i
    
15. Sheet2.Range("a2").Resize(k, 2) = crr
    
16. End Sub
    
17. 
    

复制代码

跳转到最佳答案楼层

zhangchenld

可能是我问题描述的不够准确，未能收到完全符合效果的答案，自己绊绊磕磕的写了一个，供大家参考指正。

excel用户1116

示例.zip (14.89 KB, 下载次数: 7)

2022-2-16 16:27 上传

点击文件名下载附件

就当前附件，测试一个！！

zhangchenld

excel用户1116 发表于 2022-2-16 16:27
就当前附件，测试一个！！

数据行数多了以后提示内存溢出，改了brr的列数后，无法统计到所有的产品，基本只能统计一个两个，麻烦在帮忙看一下，感谢。

林木水

1. Sub text()
   
2. Dim i As Integer, j As Integer, arr, brr, crr(1 To 10000, 1 To 2), k As Integer
   
3. arr = Sheet1.Range("b2:j6")
   
4. brr = Sheet1.Range("a2:a6")
   
5. For i = 1 To UBound(brr)
   
6. For j = 1 To UBound(arr, 2)
   
7. If arr(i, j) = "" Then
   
8. Else
   
9. k = k + 1
   
10. crr(k, 1) = brr(i, 1)
    
11. crr(k, 2) = arr(i, j)
    
12. End If
    
13. Next j
    
14. Next i
    
15. Sheet2.Range("a2").Resize(k, 2) = crr
    
16. End Sub
    
17. 
    

复制代码

zhangchenld

林木水 发表于 2022-2-16 18:49

好像反了，是从sheet2往sheet1统计

林木水

zhangchenld 发表于 2022-2-16 20:11
好像反了，是从sheet2往sheet1统计

那就更加简单了，可以用公式就很简单的解决了。
汇总表的B2单元格输入公式: =XLOOKUP($A2&SUBSTITUTE(B$1,"型号","产品",1),明细表!$A:$A&明细表!$B:$B,明细表!$B:$B,"")

或者VBA代码：

1. Sub demo()
   
2. Dim i As Integer, j As Integer, k As Integer, arr, brr
   
3.     arr = Sheet1.Range("a2:a" & Sheet1.Cells(Rows.Count, 1).End(xlUp).Row)
   
4.     brr = Sheet2.Range("a2:b" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row)
   
5.     ReDim crr(1 To UBound(arr), 1 To 9)
   
6.     For i = 1 To UBound(arr)
   
7.         For j = 1 To 9
   
8.             For k = 1 To UBound(brr)
   
9.                 If arr(i, 1) = brr(k, 1) And brr(k, 2) = "产品" & j Then
   
10.                     crr(i, j) = brr(k, 2)
    
11.                     Exit For
    
12.                 End If
    
13.             Next k
    
14.         Next j
    
15.     Next i
    
16.     Sheet1.Range("b2").Resize(UBound(crr), UBound(crr, 2)) = crr
    
17. End Sub
    

复制代码

蜀西

林木水 发表于 2022-2-16 21:49

版主大神，，帮我看看这个问题。
http://www.excelpx.com/forum.php ... d=466460&extra=
这是帖子的地址