[已解决]请修改程序

ymq123

请修改程序
把工作簿GFC3工作表2中12个数字进行组合，组合结果放到工作簿GFC301工作表5内
Set sh1 = Workbooks("GFC3.xlsm").Sheets(EE1) 出现下标越界
ReDim brr(1 To d.Count, 1 To 12) 也出错
数据组合程序是正确的

最佳答案

月排行榜 / 总排行榜

xdragon

2015-1-11 14:18

1. Private Sub CommandButton1_Click()
   
2. Call 组合数据_Click
   
3. End Sub
   
4. Private Sub 组合数据_Click()
   
5. 
   
6. Workbooks.Open ThisWorkbook.Path & "\GFC301.xlsm"
   
7. Workbooks("GFC301.xlsm").Sheets("5").Select
   
8. Workbooks("GFC301.xlsm").Sheets("5").Cells.Clear
   
9.   
   
10. EE1 = "2": EE2 = "5": EE3 = 301     'EE1、EE2、EE3 是变量
    
11. 
    
12. 
    
13. 组合7 EE1, EE2, EE3
    
14. 
    
15. ' Sheets("3").Cells.Clear  这行貌似多于。。。
    
16. End Sub
    
17. 
    
18. 
    
19. Sub 组合7(EE1, EE2, EE3)
    
20. Dim sh1, sh2 As Worksheet
    
21. Set sh1 = Workbooks("GFC3.xlsm").Sheets(EE1)        'EE1是变量
    
22. 
    
23. Set sh2 = Workbooks("GFC" & EE3 & ".xlsm").Sheets(EE2)   'EE2、EE3 是变量
    
24. 
    
25. 
    
26. Dim arr, i&, R%, s(), j&, i1&, i2&, i3&, i4&, i5&, x$, y%
    
27. Dim d, k, brr
    
28. Set d = CreateObject("Scripting.Dictionary")
    
29. 
    
30. arr = sh1.Range(sh1.Cells(1, 1), sh1.Cells(1, 12))
    
31. Debug.Print sh1.Range(sh1.Cells(1, 1), sh1.Cells(1, 12)).Address(False, False)
    
32. 
    
33. For i = 1 To UBound(arr)
    
34.     For j = 1 To UBound(arr, 2)
    
35.       If arr(i, j) <> "" Then
    
36.         R = R + 1
    
37.         ReDim Preserve s(1 To R)
    
38.         s(R) = arr(i, j)
    
39.       End If
    
40.     Next
    
41. If R >= 7 Then
    
42. For i1 = 1 To R - 6
    
43. For i2 = i1 + 1 To R - 5
    
44. For i3 = i2 + 1 To R - 4
    
45. For i4 = i3 + 1 To R - 3
    
46. For i5 = i4 + 1 To R - 2
    
47. For i6 = i5 + 1 To R - 1
    
48. For i7 = i6 + 1 To R
    
49.    x = s(i1) & "," & s(i2) & "," & s(i3) & "," & s(i4) & "," & s(i5) & "," & s(i6) & "," & s(i7)
    
50. d(x) = ""
    
51. Next
    
52. Next
    
53. Next
    
54. Next
    
55. Next
    
56. Next
    
57. Next
    
58. End If
    
59. R = 0
    
60. Next
    
61.    k = d.keys
    
62.    ReDim brr(1 To d.Count, 1 To 12)
    
63.    For i = 0 To UBound(k)
    
64.      aa = Split(k(i), ",")
    
65.      For j = 0 To UBound(aa)
    
66.        brr(i + 1, aa(j)) = aa(j)
    
67.      Next
    
68.    Next
    
69. sh2.Cells(1, 1).Resize(UBound(brr), 12) = brr
    
70. d.RemoveAll
    
71. End Sub

复制代码

改动的地方挺多的，你自己参照这看看吧。

跳转到最佳答案楼层

xdragon

1. Private Sub CommandButton1_Click()
   
2. Call 组合数据_Click
   
3. End Sub
   
4. Private Sub 组合数据_Click()
   
5. 
   
6. Workbooks.Open ThisWorkbook.Path & "\GFC301.xlsm"
   
7. Workbooks("GFC301.xlsm").Sheets("5").Select
   
8. Workbooks("GFC301.xlsm").Sheets("5").Cells.Clear
   
9.   
   
10. EE1 = "2": EE2 = "5": EE3 = 301     'EE1、EE2、EE3 是变量
    
11. 
    
12. 
    
13. 组合7 EE1, EE2, EE3
    
14. 
    
15. ' Sheets("3").Cells.Clear  这行貌似多于。。。
    
16. End Sub
    
17. 
    
18. 
    
19. Sub 组合7(EE1, EE2, EE3)
    
20. Dim sh1, sh2 As Worksheet
    
21. Set sh1 = Workbooks("GFC3.xlsm").Sheets(EE1)        'EE1是变量
    
22. 
    
23. Set sh2 = Workbooks("GFC" & EE3 & ".xlsm").Sheets(EE2)   'EE2、EE3 是变量
    
24. 
    
25. 
    
26. Dim arr, i&, R%, s(), j&, i1&, i2&, i3&, i4&, i5&, x$, y%
    
27. Dim d, k, brr
    
28. Set d = CreateObject("Scripting.Dictionary")
    
29. 
    
30. arr = sh1.Range(sh1.Cells(1, 1), sh1.Cells(1, 12))
    
31. Debug.Print sh1.Range(sh1.Cells(1, 1), sh1.Cells(1, 12)).Address(False, False)
    
32. 
    
33. For i = 1 To UBound(arr)
    
34.     For j = 1 To UBound(arr, 2)
    
35.       If arr(i, j) <> "" Then
    
36.         R = R + 1
    
37.         ReDim Preserve s(1 To R)
    
38.         s(R) = arr(i, j)
    
39.       End If
    
40.     Next
    
41. If R >= 7 Then
    
42. For i1 = 1 To R - 6
    
43. For i2 = i1 + 1 To R - 5
    
44. For i3 = i2 + 1 To R - 4
    
45. For i4 = i3 + 1 To R - 3
    
46. For i5 = i4 + 1 To R - 2
    
47. For i6 = i5 + 1 To R - 1
    
48. For i7 = i6 + 1 To R
    
49.    x = s(i1) & "," & s(i2) & "," & s(i3) & "," & s(i4) & "," & s(i5) & "," & s(i6) & "," & s(i7)
    
50. d(x) = ""
    
51. Next
    
52. Next
    
53. Next
    
54. Next
    
55. Next
    
56. Next
    
57. Next
    
58. End If
    
59. R = 0
    
60. Next
    
61.    k = d.keys
    
62.    ReDim brr(1 To d.Count, 1 To 12)
    
63.    For i = 0 To UBound(k)
    
64.      aa = Split(k(i), ",")
    
65.      For j = 0 To UBound(aa)
    
66.        brr(i + 1, aa(j)) = aa(j)
    
67.      Next
    
68.    Next
    
69. sh2.Cells(1, 1).Resize(UBound(brr), 12) = brr
    
70. d.RemoveAll
    
71. End Sub

复制代码

改动的地方挺多的，你自己参照这看看吧。