'2-5组合全输出，自己挑选，，，
Option Explicit
Sub test()
Dim arr, brr, i As Long, j As Long, n As Long, p As Long
Dim m As Long, k As Long, kk As Long
brr = Range("a5:b" & [a5].End(xlDown).Row)
ReDim arr(1 To UBound(brr, 1) * 2, 1 To 2)
For i = 1 To UBound(brr, 1)
arr(i, 1) = "+" & brr(i, 1): arr(i, 2) = brr(i, 2)
arr(UBound(brr, 1) + i, 1) = "-" & brr(i, 1)
arr(UBound(brr, 1) + i, 2) = -brr(i, 2)
Next
[a16].Resize(UBound(arr, 1), 2) = arr
ReDim brr(1 To 2 ^ UBound(arr, 1) + 1, 1 To 3)
ReDim crr(1 To 2 ^ UBound(arr, 1), 1 To 3)
brr(2, 1) = arr(1, 1): brr(2, 2) = arr(1, 2): brr(2, 3) = 1
n = 2
For i = 2 To UBound(arr, 1)
For j = n + 1 To 2 * n
brr(j, 1) = brr(j - n, 1) & arr(i, 1)
brr(j, 2) = brr(j - n, 2) + arr(i, 2)
brr(j, 3) = brr(j - n, 3) + 1
Next
n = n * 2
Next
ReDim arr(1 To 10 ^ 6, 1 To 3) As String
Call qsort(brr, 2, UBound(brr, 1) - 1, 1, 3, 3)
p = 2
For i = 2 To UBound(brr, 1) - 1
If brr(i, 3) <> brr(i + 1, 3) Then
Call qsort(brr, p, i, 1, 3, 2)
If brr(i, 3) >= 2 And brr(i, 3) <= 5 Then '取2-5组合
For j = p To i - 1
For k = j + 1 To i
If brr(k, 2) - brr(j, 2) > 0.9 Then
If k - j > 2 Then
For kk = j To k - 1
m = m + 1
arr(m, 1) = brr(kk, 1)
arr(m, 2) = brr(kk, 2)
arr(m, 3) = brr(kk, 3)
Next
m = m + 1
End If
Exit For
End If
Next
Next
End If
p = i + 1
End If
Next
Debug.Print m
[m1].Resize(, 3) = Split("组,结果,组合数", ",")
With [m2]
.Resize(Rows.Count - 1, 3).ClearContents
If m > 0 Then .Resize(m, 3) = arr
End With
End Sub
Sub qsort(arr, first, last, left, right, key)
Dim i As Long, j As Long, k As Long, x, t
i = first: j = last: x = arr((first + last) / 2, key)
While i <= j
While arr(i, key) < x: i = i + 1: Wend
While x < arr(j, key): j = j - 1: Wend
If i <= j Then
For k = left To right
t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
Next
i = i + 1: j = j - 1
End If
Wend
If first < j Then qsort arr, first, j, left, right, key
If i < last Then qsort arr, i, last, left, right, key
End Sub |
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2020-2-29 20:42
楼主
