Question

我有一个数字，我会看一个数字表，其中一个记录或最好的总和将匹配它

例如：我有号码30

以及带有数字字段的记录表

逐行

我希望在此处返回10，18，2（我的号码30的匹配）行

或

我希望在此处返回30

行

或

我希望在此处返回15，15

行

或

我希望在此处返回7，3，10，8，2

行

Answer 1

这是Harlan Grove前一段时间写的解决方案。请注意，如果有多个解决方案，则会将它们全部列出。我想它可以修改为UDF以返回单元格中的值列表。

Sub findsums()
'This *REQUIRES* VBAProject references to
'Microsoft Scripting Runtime
'Microsoft VBScript Regular Expressions 1.0 or higher

Const TOL As Double = 0.000001 'modify as needed
Dim c As Variant

Dim j As Long, k As Long, n As Long, p As Boolean
Dim s As String, t As Double, u As Double
Dim v As Variant, x As Variant, y As Variant
Dim dc1 As New Dictionary, dc2 As New Dictionary
Dim dcn As Dictionary, dco As Dictionary
Dim re As New RegExp

    re.Global = True
    re.IgnoreCase = True

    On Error Resume Next

    Set x = Application.InputBox( _
        Prompt:="Enter range of values:", _
        Title:="findsums", _
        Default:="", _
        Type:=8)

    If x Is Nothing Then
        Err.Clear
        Exit Sub
    End If

    y = Application.InputBox( _
        Prompt:="Enter target value:", _
        Title:="findsums", _
        Default:="", _
        Type:=1)

    If VarType(y) = vbBoolean Then
        Exit Sub
    Else
        t = y
    End If

    On Error GoTo 0

    Set dco = dc1
    Set dcn = dc2

    Call recsoln

    For Each y In x.Value2
        If VarType(y) = vbDouble Then
            If Abs(t - y) < TOL Then
                recsoln "+" & Format(y)

            ElseIf dco.Exists(y) Then
                dco(y) = dco(y) + 1

            ElseIf y < t - TOL Then
                dco.Add Key:=y, Item:=1

                c = CDec(c + 1)
                Application.StatusBar = "[1] " & Format(c)
            End If
        End If
    Next y

    n = dco.Count

    ReDim v(1 To n, 1 To 3)

    For k = 1 To n
        v(k, 1) = dco.Keys(k - 1)
        v(k, 2) = dco.Items(k - 1)
    Next k

    qsortd v, 1, n

    For k = n To 1 Step -1
        v(k, 3) = v(k, 1) * v(k, 2) + v(IIf(k = n, n, k + 1), 3)
        If v(k, 3) > t Then dcn.Add Key:="+" & _
            Format(v(k, 1)), Item:=v(k, 1)
    Next k

    On Error GoTo CleanUp
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    For k = 2 To n
        dco.RemoveAll
        swapo dco, dcn

        For Each y In dco.Keys
            p = False

            For j = 1 To n
                If v(j, 3) < t - dco(y) - TOL Then Exit For
                x = v(j, 1)
                s = "+" & Format(x)
                If Right(y, Len(s)) = s Then p = True
                If p Then
                    re.Pattern = "\" & s & "(?=(\+|$))"
                    If re.Execute(y).Count < v(j, 2) Then
                        u = dco(y) + x
                        If Abs(t - u) < TOL Then
                            recsoln y & s
                        ElseIf u < t - TOL Then
                            dcn.Add Key:=y & s, Item:=u
                            c = CDec(c + 1)
                            Application.StatusBar = "[" & Format(k) & "] " & _
                            Format(c)
                        End If
                    End If
                End If
            Next j
        Next y

        If dcn.Count = 0 Then Exit For
    Next k

    If (recsoln() = 0) Then _
        MsgBox Prompt:="all combinations exhausted", _
        Title:="No Solution"

CleanUp:
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = False
End Sub

Private Function recsoln(Optional s As String)
Const OUTPUTWSN As String = "findsums solutions" 'modify to taste

Static r As Range
Dim ws As Worksheet

    If s = "" And r Is Nothing Then
        On Error Resume Next
        Set ws = ActiveWorkbook.Worksheets(OUTPUTWSN)
        If ws Is Nothing Then
            Err.Clear
            Application.ScreenUpdating = False
            Set ws = ActiveSheet
            Set r = Worksheets.Add.Range("A1")
            r.Parent.Name = OUTPUTWSN
            ws.Activate
            Application.ScreenUpdating = False
        Else
            ws.Cells.Clear
            Set r = ws.Range("A1")
        End If
        recsoln = 0
    ElseIf s = "" Then
        recsoln = r.Row - 1
        Set r = Nothing
    Else
        r.Value = s
        Set r = r.Offset(1, 0)
        recsoln = r.Row - 1
    End If
End Function

Private Sub qsortd(v As Variant, lft As Long, rgt As Long)
'ad hoc quicksort subroutine
'translated from Aho, Weinberger & Kernighan,
'"The Awk Programming Language", page 161
Dim j As Long, pvt As Long

    If (lft >= rgt) Then Exit Sub

    swap2 v, lft, lft + Int((rgt - lft + 1) * Rnd)
    pvt = lft
    For j = lft + 1 To rgt
        If v(j, 1) > v(lft, 1) Then
        pvt = pvt + 1
        swap2 v, pvt, j
       End If
    Next j

    swap2 v, lft, pvt

    qsortd v, lft, pvt - 1
    qsortd v, pvt + 1, rgt
 End Sub

 Private Sub swap2(v As Variant, i As Long, j As Long)
 'modified version of the swap procedure from
 'translated from Aho, Weinberger & Kernighan,
 '"The Awk Programming Language", page 161

 Dim t As Variant, k As Long

    For k = LBound(v, 2) To UBound(v, 2)
        t = v(i, k)
        v(i, k) = v(j, k)
        v(j, k) = t
    Next k
 End Sub

 Private Sub swapo(a As Object, b As Object)
 Dim t As Object

    Set t = a
    Set a = b
    Set b = t
 End Sub
 '---- end VBA code ----

从表中查找总和匹配的最佳方法

1 个答案: