组合结果全对就判断为对， 1个结果有错则为错

Nsp=娜！再来#

lsdongjh 发表于 2019-1-15 15:46
lngMin = Application.WorksheetFunction.Min(Application.WorksheetFunction.Index(arr, 0, 3))
   ...

这个手动修改最小行和最大行的方法，可以解决问题，谢谢老师！

Nsp=娜！再来#

zopey 发表于 2019-1-15 14:22
lngRow = 65537  ，运行ok
------------------------------------------------------分界线
lngRow = 655 ...

老师的观察力不错呀！

Nsp=娜！再来#

感谢lsdongjh老师为我解惑，用lsdongjh老师的代码如下：

1. Sub test()
   
2.     Dim shData As Worksheet
   
3.     Dim arr As Variant, lngRow As Long, lngCol As Long
   
4.     Dim lngMin As Long, lngMax As Long, lngPeriod As Long
   
5.     Dim strPeriod() As String, lngIndex As Long
   
6.     Dim strTemp As String, strSplitTemp() As String, strBloon As String
   
7.     Dim lngCount() As Long, lngBloon() As Long
   
8.     Dim strResult() As Variant, lngTrue As Long
   
9.     Dim lngID As Long, lngSum As Long
   
10.    
    
11.     Set shData = Sheets("Sheet1")
    
12.     lngRow = shData.Range("A" & Rows.Count).End(xlUp).Row
    
13.     arr = shData.Range("A2:D" & lngRow)
    
14.    
    
15.   '  lngMin = Application.WorksheetFunction.Min(Application.WorksheetFunction.Index(arr, 0, 3))
    
16. '   lngMax = Application.WorksheetFunction.Max(Application.WorksheetFunction.Index(arr, 0, 3))
    
17.   
    
18. 'lngRow = 65537  ，运行ok
    
19. '------------------------------------------------------分界线
    
20. 'lngRow = 65538  ，运行报错
    
21. 
    
22.   
    
23.    lngMin = 24 '手动修改最小行
    
24.     lngMax = 1048576 '手动修改最大行
    
25.    
    
26.     ReDim strPeriod(lngMin To lngMax)
    
27.     ReDim strResult(0 To lngMax - lngMin + 1, 1 To 10)
    
28.     strResult(0, 1) = "期"
    
29.     strResult(0, 2) = "组合数量"
    
30.     strResult(0, 3) = "对的数量"
    
31.     strResult(0, 4) = "错的数量"
    
32.     strResult(0, 5) = "字母参与数量"
    
33.     strResult(0, 6) = "A的数量"
    
34.     strResult(0, 7) = "B的数量"
    
35.     strResult(0, 8) = "C的数量"
    
36.     strResult(0, 9) = "D的数量"
    
37.     strResult(0, 10) = "E的数量"
    
38.    
    
39.     For lngRow = LBound(arr) To UBound(arr)
    
40.         lngPeriod = arr(lngRow, 3)
    
41.         strPeriod(lngPeriod) = strPeriod(lngPeriod) & "," & arr(lngRow, 2) & arr(lngRow, 4)
    
42.     Next
    
43.    
    
44.     lngIndex = 0
    
45.    
    
46.     For lngRow = LBound(strPeriod) To UBound(strPeriod)
    
47.         lngIndex = lngIndex + 1
    
48.         strResult(lngIndex, 1) = lngRow
    
49.         If strPeriod(lngRow) <> "" Then
    
50.             ReDim lngCount(1 To 5) As Long
    
51.             ReDim lngBloon(1 To 5) As Long
    
52.             strSplitTemp = Split(strPeriod(lngRow), ",")
    
53.             For lngID1 = 1 To UBound(strSplitTemp)
    
54.                 strTemp = Mid(strSplitTemp(lngID1), 1, 1)
    
55.                 strBloon = right(strSplitTemp(lngID1), 1)
    
56.                 Select Case UCase(strTemp)
    
57.                     Case "A", "B", "C", "D", "E"
    
58.                         lngID = Asc(UCase(strTemp)) - 64
    
59.                         lngCount(lngID) = lngCount(lngID) + 1
    
60.                         If strBloon = "对" Then lngBloon(lngID) = lngBloon(lngID) + 1
    
61.                End Select
    
62.             Next
    
63.             lngID = 0: lngSum = 1: lngTrue = 1
    
64.             For lngCol = 1 To 5
    
65.                 If lngCount(lngCol) > 0 Then
    
66.                     lngTrue = lngTrue * lngBloon(lngCol)
    
67.                     lngID = lngID + 1
    
68.                     lngSum = lngSum * lngCount(lngCol)
    
69.                 End If
    
70.             Next
    
71.             strResult(lngIndex, 2) = lngSum
    
72.             strResult(lngIndex, 3) = lngTrue
    
73.             strResult(lngIndex, 4) = lngSum - lngTrue
    
74.             strResult(lngIndex, 5) = lngID
    
75.             strResult(lngIndex, 6) = lngCount(1)
    
76.             strResult(lngIndex, 7) = lngCount(2)
    
77.             strResult(lngIndex, 8) = lngCount(3)
    
78.             strResult(lngIndex, 9) = lngCount(4)
    
79.             strResult(lngIndex, 10) = lngCount(5)
    
80.             
    
81.          Else
    
82.             For lngCol = 2 To 10
    
83.                 strResult(lngIndex, lngCol) = 0
    
84.             Next
    
85.         End If
    
86.         
    
87.     Next
    
88.    
    
89.     shData.Range("F1:O" & Rows.Count).Clear
    
90.     shData.Range("F1").Resize(UBound(strResult) + 1, 10) = strResult
    
91. End Sub
    

复制代码

dsmch

留个标记…………

1. Sub dsmch()
   
2. Dim arr, brr, d, x, i&, zf$, z$
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("a1").CurrentRegion
   
5. w = Array("A", "B", "C", "D", "E")
   
6. ReDim x(4)
   
7. For i = 2 To UBound(arr)
   
8.     z = left(arr(i, 2), 1)
   
9.     If Not d.exists(arr(i, 3)) Then
   
10.         d(arr(i, 3)) = ""
    
11.         Set d(arr(i, 3)) = CreateObject("scripting.dictionary")
    
12.     End If
    
13.     d(arr(i, 3))(z) = d(arr(i, 3))(z) & "," & i
    
14. Next
    
15. ReDim brr(1 To d.Count, 1 To 10)
    
16. For Each a In d.keys
    
17.     n = 1: n2 = 0: s = s + 1
    
18.     brr(s, 1) = a
    
19.     brr(s, 5) = d(a).Count
    
20.     For i = 0 To UBound(w)
    
21.         If Not d(a).exists(w(i)) Then d(a)(w(i)) = ",1"
    
22.         zf = d(a)(w(i))
    
23.         x(i) = Split(zf, ",")
    
24.         c = UBound(x(i))
    
25.         If c > 0 Then n = n * c
    
26.         brr(s, i + 6) = IIf(zf = ",1", c - 1, c)
    
27.     Next
    
28.     brr(s, 2) = n
    
29.     For i0 = 1 To UBound(x(0))
    
30.         For i1 = 1 To UBound(x(1))
    
31.             For i2 = 1 To UBound(x(2))
    
32.                 For i3 = 1 To UBound(x(3))
    
33.                     For i4 = 1 To UBound(x(4))
    
34.                         zf = arr(x(0)(i0), 4) & arr(x(1)(i1), 4) & arr(x(2)(i2), 4) & arr(x(3)(i3), 4) & arr(x(4)(i4), 4)
    
35.                         If InStr(zf, "错") > 0 Then n2 = n2 + 1
    
36.                     Next
    
37.                 Next
    
38.             Next
    
39.         Next
    
40.     Next
    
41.     brr(s, 4) = n2
    
42.     brr(s, 3) = brr(s, 2) - brr(s, 4)
    
43. Next
    
44. Range("n8").Resize(s, 10) = brr
    
45. End Sub

复制代码

一把小刀闯天下

'好玩而已。修改了一下用时小于1s，完全可以接受，，，

Option Explicit

Sub test()
  Dim arr, kk As Long, m As Long, n As Long, dic, t, p As Long, sum, a As Long, tt
  Dim i1  As Long, i2 As Long, i3 As Long, i4 As Long, i5 As Long
  Dim x As Long, y As Long, i As Long, j As Long, k As Long
  tt = Timer
  Set dic = CreateObject("scripting.dictionary")
  arr = [a1].CurrentRegion.Offset(1)
  ReDim crr(1 To 10 ^ 5, 1 To 8) As String
  ReDim drr(1 To UBound(arr, 1), 1 To 10)
  For i = 1 To UBound(arr, 1) - 1
    For j = i To UBound(arr, 1) - 1
      If arr(j, 3) <> arr(j + 1, 3) Then
        For x = i To j - 1
          For y = x + 1 To j
            If arr(x, 2) > arr(y, 2) Then
              For k = 1 To 4
                t = arr(x, k): arr(x, k) = arr(y, k): arr(y, k) = t
              Next
            End If
        Next y, x
        ReDim brr(1 To 5, 1 To 20) As String, cnt(1 To 5) As Long
        m = 1: n = 0: dic.RemoveAll
        ReDim sum(65 To 69), mark(1 To 5) As Long
        For k = i To j
          n = n + 1: brr(Asc(left(arr(k, 2), 1)) - 64, n) = arr(k, 2)
          If left(arr(k, 2), 1) <> left(arr(k + 1, 2), 1) Or arr(k, 3) <> arr(k + 1, 3) Then
            t = Asc(left(arr(k, 2), 1)) - 64
            cnt(t) = n: mark(t) = 1: n = 0
          End If
          dic(arr(k, 2)) = arr(k, 4)
          t = Asc(left(arr(k, 2), 1))
          sum(t) = sum(t) + 1
        Next
        For k = 1 To UBound(cnt)
          If cnt(k) = 0 Then cnt(k) = 1
        Next
        t = 0
        For i1 = 1 To cnt(1)
          If dic(brr(1, i1)) = "对" Or mark(1) = 0 Then
          For i2 = 1 To cnt(2)
            If dic(brr(2, i2)) = "对" Or mark(2) = 0 Then
            For i3 = 1 To cnt(3)
              If dic(brr(3, i3)) = "对" Or mark(3) = 0 Then
              For i4 = 1 To cnt(4)
                If dic(brr(4, i4)) = "对" Or mark(4) = 0 Then
                For i5 = 1 To cnt(5)
                  If dic(brr(5, i5)) = "对" Or mark(5) = 0 Then
                    t = t + 1
                  End If
                Next
                End If
              Next
              End If
            Next
            End If
          Next
          End If
        Next
        a = a + 1: kk = kk + cnt(1) * cnt(2) * cnt(3) * cnt(4) * cnt(5)
        drr(a, 1) = arr(i, 3): drr(a, 2) = kk - p: drr(a, 3) = t: drr(a, 4) = drr(a, 2) - t
        t = 0
        For k = 6 To 10
          drr(a, k) = sum(59 + k)
          If drr(a, k) > 0 Then t = t + 1
        Next
        drr(a, 5) = t: p = kk
        i = j: Exit For
      End If
  Next j, i
  With [f2]
    .Resize(UBound(arr, 1), UBound(drr, 2)).ClearContents
    .Resize(a, UBound(drr, 2)) = drr
  End With
  Debug.Print Format(Timer - tt, "0.00s"), "组合数:" & kk
End Sub