数据大组合的问题

杨小妹

cnmlgb9998 发表于 2024-4-6 22:09
这是昨天那题，都给你解答了，今天，你又搞个一模一样的题，就是把 4行 改成 2行！！！！

你这个PQ，不是谁都可以用得上的。现在大部份的人，还是处于一头雾水的状态。

杨小妹

shiruiqiang 发表于 2024-4-6 20:41
改一下，应该没错了

老师你好，谢谢了。按照六楼提示，把第四行的 2 改为 1
把第五行最后面的，-1去掉。
试了一下，9行，出错，结果出现不规则组合。

shiruiqiang

杨小妹 发表于 2024-4-6 22:29
老师你好，谢谢了。按照六楼提示，把第四行的 2 改为 1
把第五行最后面的，-1去掉。
试了一下，9行，出 ...

你把除了表格内的字，其余的描述文字啥都删除了。
因为是usedrange，本来是9。你现在右边的描述文字导致下标变成10了

ykcbf1100

好了，问题解决了。

ykcbf1100

代码更新一下。。。

1. Sub ykcbf()  '//2024.4.8
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set d1 = CreateObject("Scripting.Dictionary")
   
6.     Dim tm: tm = Timer
   
7.     With Sheets("Sheet1")
   
8.         r = .Cells(Rows.Count, 1).End(3).Row
   
9.         arr = .[a1].Resize(r, 24)
   
10.         For i = 1 To UBound(arr)
    
11.             s = arr(i, 13)
    
12.             d1(s) = ""
    
13.         Next
    
14.         For Each k In d1.keys
    
15.             n = n + 1
    
16.             For i = 1 To UBound(arr)
    
17.                 s = arr(i, 13)
    
18.                 If s = k Then
    
19.                     d(n) = i
    
20.                     Exit For
    
21.                 End If
    
22.             Next
    
23.         Next
    
24.     End With
    
25.     ReDim brr(1 To 100000, 1 To UBound(arr, 2))
    
26.     On Error Resume Next
    
27.     m = 0
    
28.     For k = 1 To d.Count
    
29.         r1 = d(k)
    
30.         If k = d.Count Then r2 = r Else r2 = d(k + 1) - 1
    
31.         For i = r1 To r2
    
32.             For x = i + 1 To r2
    
33.                 m = m + 3
    
34.                 For j = 1 To UBound(arr, 2)
    
35.                     brr(m - 2, j) = arr(i, j)
    
36.                     brr(m - 1, j) = arr(x, j)
    
37.                 Next j
    
38.             Next x
    
39.         Next i
    
40.     Next
    
41.     With Sheets("Sheet2")
    
42.         .UsedRange = ""
    
43.         .[a1].Resize(m, 24) = brr
    
44.     End With
    
45.     Set d = Nothing
    
46.     Application.ScreenUpdating = True
    
47.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
48. End Sub
    

复制代码