VBA实现EXCEL某一列的部分数据和等于指定值

Dim sj(), sj1, sj2, jg(), cnt&, d&, h&, hh&, k&, l&, m&, n&, nn&, p&, q&
Sub kagawa()
tms = Timer
d = [h3]: l = [h6]: If l = 0 Then l = 65535
h = [h1] * 10 ^ d: hh = [h2] * 10 ^ d: If hh > h Then hh = hh - h

If [h7] = 0 Then p = 10 ^ 5 Else p = 10 ^ [h7]

m = [a1].CurrentRegion.Rows.Count - 1
n = [h4]: nn = [h5]: If nn = 0 Then If n = 0 Then nn = m Else nn = n
If Application.Count([d2].Resize(m)) = m And Application.Sum([d2].Resize(m)) = (m + 1) * m / 2 Then
[a1].CurrentRegion.Sort [d2], 1, , , , , , 1
Else
[d2].Resize(m) = "": [d2] = 1: [d2].Resize(m).DataSeries Rowcol:=xlColumns
End If

[a2].Resize(m, 5).Sort [c2], 1, , , , , , 2
sj1 = [a2].Resize(m, 6)
[e2].Resize(m) = "":
sj2 = [e2].Resize(m)
For i = 1 To m
sj1(i, 1) = 0
sj1(i, 5) = i
sj1(i, 6) = sj1(i, 3) * 10 ^ d 'Val2
Next

ReDim jg(l, 3)
k = 0: cnt = 0
For j = 1 To l
l = 0
ReDim sj(m, 6): m = 0
For i = 1 To UBound(sj1)
If sj2(i, 1) = "" Then
m = m + 1
sj(m, 1) = sj1(i, 1) 'not used now
sj(m, 2) = sj1(i, 2) 'Code
sj(m, 3) = sj1(i, 3) 'Val
sj(m, 4) = sj1(i, 4) 'Row
sj(m, 5) = sj1(i, 5) 'i
sj(m, 6) = sj1(i, 6) 'Val2
sj(m, 0) = sj(m - 1, 0) + sj(m, 6) 'Sum
End If
Next
cnt = 0: q = 0: Call dgH42(h, "", "", m + 1, 1)
If cnt > p Then Exit For Else CalcCnt = CalcCnt + cnt
If j > k Then Exit For Else [h6] = k
Next
If m Then
jg(k, 0) = k + 1
jg(k, 2) = sj(m, 0)
s = "": t = 0
For i = 1 To m
t = t + 1
s = s & "+" & sj(i, 2)
sj2(sj(i, 5), 1) = k + 1
Next
jg(k, 1) = t
jg(k, 3) = Mid(s, 2)
k = k + 1
[h6] = k
End If
If k And k < 65535 Then [k1].CurrentRegion.Offset(1) = "": [k2].Resize(k, 4) = jg

[e2].Resize(UBound(sj2)) = sj2
MsgBox "Result: " & k & "/ Calc " & CalcCnt & " Time: " & Format(Timer - tms, "0.000s")

[a1].CurrentRegion.Sort [e2], 1, [d2], , 1, , , 1
End Sub
Sub dgH42(r&, ri$, ra$, i&, t&)
Dim j&, t1&, r2&, rs#
If l Then Exit Sub
cnt = cnt + 1: If cnt > p Then Exit Sub
'    Exit Sub
If t >= n And t <= nn Then
r2 = r + hh
For j = 1 To i - 1
'            If q Then Stop
If sj(j, 1) * q Then
'                MsgBox sj(j, 1) & "/" & sj(j, 2) & "/" & q
Else
t1 = sj(j, 6) 'Val2
If r <= t1 And t1 <= r2 Then
jg(k, 0) = k + 1
jg(k, 1) = t
jg(k, 3) = Mid(ra, 2) & "+" & sj(j, 2)
rs = 0
x = Split(ri & "," & j, ",")
For l = 1 To UBound(x)
rs = rs + sj1(sj(x(l), 5), 3) 'Val
sj2(sj(x(l), 5), 1) = k + 1
Next
jg(k, 2) = rs
k = k + 1
Exit Sub
ElseIf t1 > r2 Then
Exit For
End If
End If
Next
End If
If t = nn Then Exit Sub

For j = i - 1 To 2 Step -1
If sj(j, 1) * q Then
'            MsgBox sj(j, 1) & "/" & sj(j, 2) & "/" & q
Else
If sj(j, 6) < r + hh Then 'Val2
If sj(j, 0) < r Then 'Sum
Exit For
Else
If sj(j, 1) Then q = 1
Call dgH42(r - sj(j, 6), ri & "," & j, ra & "+" & sj(j, 2), j, t + 1)
End If
End If
End If
Next

End Sub
Sub mySort()
sj0 = [a1].CurrentRegion
m = UBound(sj0) - 1
k = Application.Sum([d2].Resize(m))
If Application.Count([d2].Resize(m)) = m And k = (m + 1) * m / 2 Then [a1].CurrentRegion.Sort [d2], 1, , , , , , 1
End Sub