'75.36s 组合数:43379885
Option Explicit
Sub test()
Dim arr, i, j, k, kk, kkk, m, n, dic, t, p, sum, a, tt
Dim i1, i2, i3, i4, i5
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
Call dsort(arr, i, j, 1, UBound(arr, 2), 2)
ReDim brr(1 To 5, 1 To 20) As String, cnt(1 To 5) As Integer
m = 1: n = 0: dic.RemoveAll
ReDim sum(65 To 69)
For k = i To j
n = n + 1: brr(m, n) = arr(k, 2)
If left(arr(k, 2), 1) <> left(arr(k + 1, 2), 1) Then
cnt(m) = n: m = m + 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: p = kk: kkk = 0
For i1 = 1 To cnt(1)
For i2 = 1 To cnt(2)
For i3 = 1 To cnt(3)
For i4 = 1 To cnt(4)
For i5 = 1 To cnt(5)
kk = kk + 1: kkk = kkk + 1
crr(kkk, 7) = arr(i, 3): crr(kkk, 1) = kkk
crr(kkk, 2) = brr(1, i1): crr(kkk, 3) = brr(2, i2)
crr(kkk, 4) = brr(3, i3): crr(kkk, 5) = brr(4, i4): crr(kkk, 6) = brr(5, i5)
For k = 2 To 6
If dic(crr(kkk, k)) = "错" Then Exit For
Next
If k = 7 Then t = t + 1
Next i5, i4, i3, i2, i1
a = a + 1
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 Len(drr(a, k)) 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
Function dsort(arr, first, last, left, right, key)
Dim i, j, k, t
For i = first To last - 1
For j = i + 1 To last
If arr(i, key) > arr(j, key) Then
For k = left To right
t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
Next
End If
Next j, i
End Function |