Давайте пойдем в другом направлении и покажем, какие две ячейки можно суммировать для соответствия критериям, см. Изображение ниже.
Все еще большая проблема вопроса. Я буду продолжать играть с более полным ответом 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
Макрос производит картинку ниже.
