文本的多条件分类汇总

3190496160

发发哥abc 发表于 2024-10-15 16:55
额  你说的对  。我是疏忽了  sorry   但是  横着排 并不是想要的结果

论坛是做义务的，没有多少人有耐心一直陪你玩儿的，所以，一开始就要把自己的真实意图表述清楚，别人给你的代码，认真测试后，一次性反馈目前代码结果存在的问题，

发发哥abc

3190496160 发表于 2024-10-15 16:59
论坛是做义务的，没有多少人有耐心一直陪你玩儿的，所以，一开始就要把自己的真实意图表述清楚，别人给你 ...

额  好的  受教了  

铁马1980

借地儿练手JSA











导出1111.zip (12.28 KB, 下载次数: 5)

2024-10-16 11:55 上传

点击文件名下载附件

发发哥abc

铁马1980 发表于 2024-10-15 21:35
借地儿练手JSA

十分感谢  可惜看不懂

蓝桥玄霜

请见代码：

1. Sub lqxs()
   
2. Dim arr, i, x$, y$, kk, tt, aa, ii%, j%, c%, n%, nn%
   
3. Dim d, k, t, d1, d2
   
4. Set d = CreateObject("scripting.dictionary")
   
5. Set d1 = CreateObject("scripting.dictionary")
   
6. Set d2 = CreateObject("scripting.dictionary")
   
7. Sheet2.Activate
   
8. [d:m].ClearContents: c = 4
   
9. arr = Sheet1.[a1].CurrentRegion
   
10. For i = 2 To UBound(arr)
    
11.     y = arr(i, 1): x = arr(i, 2)
    
12.     If Not d1.exists(x) Then c = c + 1: d1(x) = c
    
13.     If d.exists(x) = False Then Set d(x) = CreateObject("scripting.dictionary")
    
14.     d(x)(y) = d(x)(y) & arr(i, 3) & ","
    
15. Next
    
16. [e1].Resize(1, d1.Count) = d1.keys
    
17. k = d.keys: t = d.items: n = 1
    
18. For i = 0 To UBound(k)
    
19.     c = d1(k(i)): nn = 0
    
20.     kk = t(i).keys: tt = t(i).items
    
21.     For ii = 0 To UBound(kk)
    
22.         If Not d2.exists(kk(ii)) Then
    
23.             n = n + 1
    
24.             Cells(n, 4) = kk(ii)
    
25.             d2(kk(ii)) = d2(kk(ii)) & n & ","
    
26.         Else
    
27.             t2 = d2(kk(ii))
    
28.             t2 = Left(t2, Len(t2) - 1)
    
29.             If InStr(t2, ",") Then
    
30.                 aa = Split(t2, ",")
    
31.                 For j = 0 To UBound(aa)
    
32.                     If Cells(Val(aa(j)), c) = "" Then nn = Val(aa(j)): Exit For
    
33.                 Next
    
34.             Else
    
35.                 nn = Val(t2)
    
36.             End If
    
37.         End If
    
38.         tt(ii) = Left(tt(ii), Len(tt(ii)) - 1)
    
39.         If InStr(tt(ii), ",") Then
    
40.             aa = Split(tt(ii), ",")
    
41.             For j = 0 To UBound(aa)
    
42.                 If j > 0 Then
    
43.                     If nn = 0 Then
    
44.                         n = n + 1
    
45.                         Cells(n, 4) = kk(ii)
    
46.                         d2(kk(ii)) = d2(kk(ii)) & n & ","
    
47.                     End If
    
48.                 End If
    
49.                 If nn = 0 Then
    
50.                     Cells(n, c) = aa(j)
    
51.                 Else
    
52.                     Cells(nn, c) = aa(j)
    
53.                     If j <> UBound(aa) Then nn = nn + 1 Else nn = 0
    
54.                 End If
    
55.             Next
    
56.         Else
    
57.             If nn = 0 Then Cells(n, c) = tt(ii) Else Cells(nn, c) = tt(ii): nn = 0
    
58.         End If
    
59.     Next
    
60. Next
    
61. End Sub
    

复制代码

yanglinzi

yanglinzi

参与一下，不知是否符合你的要求

发发哥abc

yanglinzi 发表于 2024-10-16 10:58
参与一下，不知是否符合你的要求

首先十分感谢，并且数据提取完整。其次 有几点不合适。1， 需要排序  2， 每列都是连续相连的 没有空格 。3，第一列也是排序的

发发哥abc

蓝桥玄霜 发表于 2024-10-16 10:30
请见代码：

太棒了    除了 首行 和 首列 没有排序外  其余的都ok

Askinofblue

看别人写了好多代码，给你一个最简单的方法吧，只需要三行就搞定了



了解一下表堆堆，解决你这个问题只需3行代码