[已解决]求助高手老师指导，谢谢！~

fywb2000

求助高手老师指导，谢谢！~

最佳答案

月排行榜 / 总排行榜

心正意诚身修

2022-5-25 21:24

fywb2000 发表于 2022-5-25 15:06
真心感谢老师指导费心

1. Sub 数据生成()
   
2. Dim arra(), arrb(), last1 As Integer, last2 As Integer, last3 As Integer
   
3. Dim sa As Integer, sb As Integer, K, X, Y, Z, L
   
4. last1 = [b2].End(xlDown).Row
   
5. last2 = [f2].End(xlDown).Row
   
6. last3 = [j2].End(xlDown).Row
   
7. ReDim arra(1 To (last1 - 1) * (last2 - 1), 1 To 4)
   
8. For sa = 2 To last1
   
9.    For sb = 2 To last2
   
10.     K = K + 1
    
11.    arra(K, 1) = Range("b" & sa)
    
12.    arra(K, 2) = Range("c" & sa)
    
13.    arra(K, 3) = Range("f" & sb)
    
14.    arra(K, 4) = Range("g" & sb)
    
15.    Next
    
16. Next
    
17. Range("n2").Resize(K, 4) = arra
    
18. ReDim arrb(1 To K * (last3 - 1), 1 To 6)
    
19. For X = 1 To K
    
20.    For Y = 2 To last3
    
21.     Z = Z + 1
    
22.     For L = 1 To 4
    
23.     arrb(Z, L) = arra(X, L)
    
24.     arrb(Z, 5) = Range("j" & Y)
    
25.     arrb(Z, 6) = Range("k" & Y)
    
26.     Next
    
27.    Next
    
28. Next
    
29. Range("t2").Resize(Z, 6) = arrb
    
30. End Sub
    

复制代码

现在要短一点了。

跳转到最佳答案楼层

心正意诚身修

1. Sub 数据生成()
   
2. Dim arra(), arrb(), arrc, arrd(), arre(), last1 As Integer, last2 As Integer, last3 As Integer
   
3. Dim sa As Integer, sb As Integer, sc As Integer, ja As Integer, jb As Integer, jc As Integer, jd As Long, je As Long
   
4. Dim sd1, sd2, sd3, sd4, jg1(), jg2(), K, X, Y, Z
   
5. last1 = [b2].End(xlDown).Row
   
6. last2 = [f2].End(xlDown).Row
   
7. last3 = [j2].End(xlDown).Row
   
8. ReDim arra(1 To 10)
   
9. ReDim arrb(1 To 10)
   
10. ReDim arrc(1 To 10)
    
11. ReDim arrd(1 To 10)
    
12. ReDim arre(1 To 10)
    
13. For sa = 2 To last1  'a组合
    
14.    ja = ja + 1
    
15.    ReDim Preserve arra(1 To ja)
    
16.    arra(ja) = Range("b" & sa) & "|" & Range("c" & sa)
    
17. Next
    
18. For sb = 2 To last2   'B组合
    
19.    jb = jb + 1
    
20.    ReDim Preserve arrb(1 To jb)
    
21.    arrb(jb) = Range("f" & sb) & "|" & Range("g" & sb)
    
22. Next
    
23. For sd1 = 1 To last1 - 1   'AB组合
    
24.    For sd2 = 1 To last2 - 1
    
25.    jd = jd + 1
    
26.    ReDim Preserve arrd(1 To jd)
    
27.    arrd(jd) = arra(sd1) & "|" & arrb(sd2)
    
28.    Next
    
29. Next
    
30. For sc = 2 To last3    'C组合
    
31.    jc = jc + 1
    
32.    ReDim Preserve arrc(1 To jc)
    
33.    arrc(jc) = Range("j" & sc) & "|" & Range("k" & sc)
    
34. Next
    
35. For sd3 = 1 To jd     'ABC组合
    
36.    For sd4 = 1 To last3 - 1
    
37.    je = je + 1
    
38.    ReDim Preserve arre(1 To je)
    
39.    arre(je) = arrd(sd3) & "|" & arrc(sd4)
    
40.    Next
    
41. Next
    
42. 
    
43. ReDim jg1(1 To jd, 1 To 4)  '拆分AB，生成第一个要的结果
    
44.    For K = 1 To jd
    
45.       For X = 1 To 4
    
46.       jg1(K, X) = VBA.Split(arrd(K), "|")(X - 1)
    
47.       Next
    
48.    Next
    
49. Range("n2").Resize(K - 1, 4) = jg1
    
50. 
    
51. ReDim jg2(1 To je, 1 To 6)    '拆分ABC，生成第二个要的结果
    
52.    For Y = 1 To je
    
53.       For Z = 1 To 6
    
54.       jg2(Y, Z) = VBA.Split(arre(Y), "|")(Z - 1)
    
55.       Next
    
56.    Next
    
57. Range("T2").Resize(Y - 1, 6) = jg2
    
58. End Sub
    

复制代码

越走越远。。结果 就走了这么远

心正意诚身修

这么长的代码，，这么多的无规则命名的变量，，要是熊猫他们看到了。。不晓得要怼。以后我也要改改这毛病了。

心正意诚身修

先拿着用，运算速度也还可以。明天晚上我再重写。

hcm19522

N2:O2 下 拉=OFFSET(B$1,INT((ROW(A1)-1)/COUNTIF($G$2:$G$13,">0"))+1,)&""

P2:Q2 下 拉=IF(N2="","",OFFSET(F$1,MOD(ROW(A1)-1,COUNTIF($G$2:$G$13,">0"))+1,))

fywb2000

心正意诚身修 发表于 2022-5-24 21:44
越走越远。。结果 就走了这么远

真心感谢老师指导费心

心正意诚身修

fywb2000 发表于 2022-5-25 15:06
真心感谢老师指导费心

1. Sub 数据生成()
   
2. Dim arra(), arrb(), last1 As Integer, last2 As Integer, last3 As Integer
   
3. Dim sa As Integer, sb As Integer, K, X, Y, Z, L
   
4. last1 = [b2].End(xlDown).Row
   
5. last2 = [f2].End(xlDown).Row
   
6. last3 = [j2].End(xlDown).Row
   
7. ReDim arra(1 To (last1 - 1) * (last2 - 1), 1 To 4)
   
8. For sa = 2 To last1
   
9.    For sb = 2 To last2
   
10.     K = K + 1
    
11.    arra(K, 1) = Range("b" & sa)
    
12.    arra(K, 2) = Range("c" & sa)
    
13.    arra(K, 3) = Range("f" & sb)
    
14.    arra(K, 4) = Range("g" & sb)
    
15.    Next
    
16. Next
    
17. Range("n2").Resize(K, 4) = arra
    
18. ReDim arrb(1 To K * (last3 - 1), 1 To 6)
    
19. For X = 1 To K
    
20.    For Y = 2 To last3
    
21.     Z = Z + 1
    
22.     For L = 1 To 4
    
23.     arrb(Z, L) = arra(X, L)
    
24.     arrb(Z, 5) = Range("j" & Y)
    
25.     arrb(Z, 6) = Range("k" & Y)
    
26.     Next
    
27.    Next
    
28. Next
    
29. Range("t2").Resize(Z, 6) = arrb
    
30. End Sub
    

复制代码

现在要短一点了。