☰

如何确定给定单元格组中哪些值将加起来达到数值范围

tag-icon • tag-icon microsoft-excel worksheet-function microsoft-excel-2003
如何确定给定单元格组中哪些值将加起来达到数值范围

换句话说，我正在寻找由数组中的单元格组合组成的总和范围。给定一组数字：

1 720 56 17 59 120 153 203 39 1 690 583 582 561 256 310 232 95 108 16 26 59 538 445 42 149

（call this A1:A26）

我正在寻找的总和范围是1000-1500。我希望能够看到来自的哪些单元格组合的A1:A5总和将在该范围内。例如取 ( A23, A24, A26) 的总和或 ( ) 的总和A2, A11。

单元格或组合的数量无关紧要，只要总数在给定范围内即可。除此之外，我需要能够识别每个组合中使用的单元格。

我感谢所有能让我的生活更轻松的人。
谢谢。

答案1

让我们换个方向看看，哪两个单元格可以相加以满足标准（见下图）。

这仍然是一个极具挑战性的问题。如果可能的话，我将继续尝试更完整的 VBA 答案。

在此处输入图片描述

我必须暂停一下，但以下是我所做的，向您展示符合条件的不同值。我绝不是 VBA 专家，我只是把这当作一次学习经历。我确信我违反了一些规则。

Sub WhatCanSUM()

Dim lst As Range
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim ilst1 As Integer
Dim ilst2 As Integer
Dim ilst3 As Integer
Dim ilst4 As Integer
Dim ilst5 As Integer
Dim ilst6 As Integer
Dim ilst7 As Integer
Dim ilst8 As Integer
Dim ilst9 As Integer
Dim ilst10 As Integer
Dim ilst11 As Integer
Dim ilst12 As Integer
Dim ilst13 As Integer
Dim ilst14 As Integer
Dim ilst15 As Integer
Dim ilst16 As Integer
Dim ilst17 As Integer
Dim ilst18 As Integer
Dim ilst19 As Integer
Dim ilst20 As Integer
Dim ilst21 As Integer
Dim ilst22 As Integer
Dim ilst23 As Integer
Dim ilst24 As Integer
Dim ilst25 As Integer
Dim ilst26 As Integer

Dim lwrlmt As Integer
Dim uprlmt As Integer
Dim result As Integer

Set lst = Sheet1.Range("lstNumbers")
i = 1
j = 1
k = 1
ilst1 = lst.Item(1).Value
ilst2 = lst.Item(2).Value
ilst3 = lst.Item(3).Value
ilst4 = lst.Item(4).Value
ilst5 = lst.Item(5).Value
ilst6 = lst.Item(6).Value
ilst7 = lst.Item(7).Value
ilst8 = lst.Item(8).Value
ilst9 = lst.Item(9).Value
ilst10 = lst.Item(10).Value
ilst11 = lst.Item(11).Value
ilst12 = lst.Item(12).Value
ilst13 = lst.Item(13).Value
ilst14 = lst.Item(14).Value
ilst15 = lst.Item(15).Value
ilst16 = lst.Item(16).Value
ilst17 = lst.Item(17).Value
ilst18 = lst.Item(18).Value
ilst19 = lst.Item(19).Value
ilst20 = lst.Item(20).Value
ilst21 = lst.Item(21).Value
ilst22 = lst.Item(22).Value
ilst23 = lst.Item(23).Value
ilst24 = lst.Item(24).Value
ilst25 = lst.Item(25).Value
ilst26 = lst.Item(26).Value
lwrmt = 1000
uprlmt = 1500
result = 0

'===============================================================================================
'Create worksheet if it doesnt exist.

Dim wrslt As Worksheet
Const strSheetName As String = "Results"

Set wrslt = Nothing
On Error Resume Next
Set wrslt = ActiveWorkbook.Worksheets(strSheetName)
On Error GoTo 0

If wrslt Is Nothing Then
    Worksheets.Add.Name = strSheetName
End If
'===============================================================================================
'Little header messagge

Set wrslt = ActiveWorkbook.Worksheets(strSheetName)
wrslt.Cells.Delete
wrslt.Cells(1, 1).Value = "Resulting Additions that 2 distinct cells that sum up to >=" & lwrmt & " and <=" & uprlmt

'===============================================================================================
'The Loop

For j = 1 To lst.Rows.Count

    For i = 1 To lst.Rows.Count
    ilst2 = lst.Item(i + 1).Value
        result = (ilst1 + ilst2)
        If ilst1 <> ilst2 And result >= lwrmt And result <= uprlmt Then
            wrslt.Cells(i + 1, j).Value = ilst1 & " + " & ilst2
        End If
    Next i

    ilst1 = lst.Item(j + 1).Value

Next j

MsgBox ("Done")
'===============================================================================================
'Formatting

wrslt.Range("A1:M1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge

wrslt.Cells.EntireColumn.AutoFit
wrslt.Cells.SpecialCells(xlCellTypeConstants, 23).Select

End Sub

该宏产生了下面的图片。 在此处输入图片描述

相关内容