文本的多条件分类汇总

发发哥abc

Askinofblue 发表于 2024-10-16 11:54
看别人写了好多代码，给你一个最简单的方法吧，只需要三行就搞定了

没有  表堆堆 这个 东西。谢谢

Askinofblue

发发哥abc 发表于 2024-10-16 14:16
没有  表堆堆 这个 东西。谢谢

百度搜索一下  表堆堆 是一个excel插件，安装一下就可以了

Qs18

1. 
   
2. Sub qs()
   
3.     Dim Sql$, i&, a
   
4.     Application.ScreenUpdating = False
   
5.      Set cnn = CreateObject("adodb.connection")
   
6.     Set rst = CreateObject("ADODB.RecordSet")
   
7.     With cnn
   
8.         .Open "Provider=Microsoft.Ace.oledb.12.0;extended properties='excel 12.0;HDR=yes';data source=" & ThisWorkbook.FullName
   
9.         Sql = "select 型号 from [源$a:c]  GROUP BY 型号  "
   
10.        End With
    
11.        rst.Open Sql, cnn, 1, 3
    
12.         a = Application.WorksheetFunction.Transpose(rst.GetRows)
    
13.     Set cnn2 = CreateObject("adodb.connection")
    
14.     Set rst2 = CreateObject("ADODB.RecordSet")
    
15.     With cnn2
    
16.         .Open "Provider=Microsoft.Ace.oledb.12.0;extended properties='excel 12.0;HDR=yes';data source=" & ThisWorkbook.FullName
    
17.       Sql2 = "select 区域 from [源$a:c]  GROUP BY 区域  "
    
18.        End With
    
19.         rst2.Open Sql2, cnn, 1, 3
    
20.          b = Application.WorksheetFunction.Transpose(rst2.GetRows)
    
21.     Set rst2 = Nothing: Set cnn2 = Nothing
    
22.     Set rst = Nothing: Set cnn = Nothing
    
23. ReDim brr(1 To UBound(a) + 1, 1 To UBound(b) + 1)
    
24.    For i = 2 To UBound(brr)
    
25.     brr(i, 1) = a(i - 1, 1)
    
26.    Next
    
27.   For j = 2 To UBound(brr, 2)
    
28.     brr(1, j) = b(j - 1, 1)
    
29.   Next j
    
30. Dim arr: arr = Sheet1.Range("a1").CurrentRegion.Value
    
31. Set dic = CreateObject("scripting.dictionary")
    
32. For i = 2 To UBound(arr)
    
33.     s = arr(i, 1) & arr(i, 2)
    
34.     If Not dic.exists(s) Then
    
35.         dic(s) = arr(i, 3)
    
36.     Else
    
37.         dic(s) = dic(s) & "," & arr(i, 3)
    
38.     End If
    
39. Next
    
40. For i = 2 To UBound(brr)
    
41.     For j = 2 To UBound(brr, 2)
    
42.         s = brr(i, 1) & brr(1, j)
    
43.         If dic.exists(s) Then
    
44.             brr(i, j) = dic(s)
    
45.         End If
    
46.     Next
    
47. Next
    
48. Sheet5.Range("a1").Resize(UBound(brr), UBound(brr, 2)) = brr
    
49. Set dic = Nothing
    
50. Application.ScreenUpdating = True
    
51. End Sub
    

复制代码

Qs18

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

Qs18

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

发发哥abc

Qs18 发表于 2024-10-18 10:19
试试..........

   这得竖列排队 应该是这样

MR_PP

发发哥abc 发表于 2024-10-18 10:24
这得竖列排队 应该是这样

在35楼Qs18 大佬的数据下重新拆分。

发发哥abc

MR_PP 发表于 2024-10-18 15:32
在35楼Qs18 大佬的数据下重新拆分。

看不懂，实在看不懂  水平有限

MR_PP

发发哥abc 发表于 2024-11-5 10:57
看不懂，实在看不懂  水平有限

是你的问题太复杂啦

笨鸟飞不高