Hello,

Here is a code that should match your rules.

But the rules do not give a result for any target value.

For example : Target = 41

[Target -10% , target + 10]% is [36.9 , 45.1]

- 41 is not a single value.

- the nearest single values (20 and 50) are not in [36.9 , 45.1]

- 41 is not a sum of two values.

- The closest sum of two different values is 30 (20+10). It does not

belong to [36.9 , 45.1]

- 41 is not a sum of three different values.

- No sum of three different values are in [36.9 , 45.1]

closest sum = 35 (20+10+5) - close to 14.6% >10% !

There could be a solution if same values are allowed (2,2 or 20,20...)

(solution = 40 (20+20).

I don't know if there are values that could not match the rules even if

same values are allowed.

If no solution exists, you can also increase the constant PerCent

to find a solution.

The code includes two constants that you can change:

Const Percent = 0.1 ' =10 % or another value

Const NoSameValues = False ' False = same values are allowed

' True = same values are not allowed

The code:

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub closest6()

' Order of preference.

' 1. One value that matches exactly with the target, else

' 2. One value that comes within 10% of the target, else

' a. Targets like 4 , 40 , 400 using twice 2, 20, 200 else

' 3. Two values that match exactly the target else

' 4. Two values which when combined come within 10% of the target

' 5. Three values that match exactly or that come within 10% of the target.

Const Percent = 0.1 '=10 %

Const NoSameValues = False ' False = same values are allowed

Dim xItems As Range, XitemMax As Long

Dim xTarget As Range, XtargetVal

Dim xIndex1 As Long, xIndex2 As Long

Dim J As Long, K As Long, M As Long

Dim xDistance As Single, xSum As Long

Set xItems = Range("Items")

XitemMax = xItems.Cells.Count

Set xTarget = Range("Target")

XtargetVal = Range("Target").Value

xTarget.Offset(1, 0).Resize(7).Value = ""

' BEG: One value that matches exactly with the target

For J = 1 To xItems.Count

If XtargetVal = xItems(J) Then

xTarget.Offset(1, 0) = "x1= " & XtargetVal

xTarget.Offset(2, 0) = "x2= "

xTarget.Offset(3, 0) = "Nearest sum= " & XtargetVal

xTarget.Offset(4, 0) = "Distance= " & Format(0, "0.00000")

xTarget.Offset(5, 0) = "% Distance of target= " & Format(Abs(XtargetVal - xItems(J)) / XtargetVal, "0.00000%")

Exit Sub

End If

Next J

' END: 1. One value that matches exactly with the target

' BEG: 2. One value that comes within Percent of the target

For J = 1 To xItems.Count

If Abs(XtargetVal - xItems(J)) <= XtargetVal * Percent Then

xTarget.Offset(1, 0) = "x1= " & xItems(J)

xTarget.Offset(2, 0) = "x2= "

xTarget.Offset(3, 0) = "Nearest sum= " & xItems(J)

xTarget.Offset(4, 0) = "Distance of target= " & Format(Abs(XtargetVal - xItems(J)), "0.00000")

xTarget.Offset(5, 0) = "% Distance of target= " & Format(Abs(XtargetVal - xItems(J)) / XtargetVal, "0.00000%")

Exit Sub

End If

Next J

' END: 2. One value that comes within Percent of the target

' BEG: a. Targets like 4 , 40 , 400 using twice 2, 20, 200

For J = 2 To xItems.Count

xSum = xItems(J - 1) + xItems(J)

If (xItems(J - 1) + xItems(J)) = XtargetVal Then

xTarget.Offset(1, 0) = "x1= " & xItems(J - 1)

xTarget.Offset(2, 0) = "x2= " & xItems(J)

xTarget.Offset(3, 0) = "Nearest sum= " & (xItems(J - 1) + xItems(J))

xTarget.Offset(4, 0) = "Distance= " & Format(Abs(XtargetVal - xSum), "0.00000")

xTarget.Offset(5, 0) = "% Distance of target= " & Format(Abs(XtargetVal - xSum) / XtargetVal, "0.00000%")

Exit Sub

End If

Next J

' END: a. Targets like 4 , 40 , 400 using twice 2, 20, 200

' BEG: 3. Two values that match exactly the target

For J = 1 To XitemMax

For K = J To XitemMax

'make the following line as comment line if twice 2,2 or 20,20 or 200,200 are allowed

If NoSameValues And xItems(J) = xItems(K) Then GoTo Lab_K

xSum = xItems(J) + xItems(K)

If xSum = XtargetVal Then

xTarget.Offset(1, 0) = "x1= " & xItems(J)

xTarget.Offset(2, 0) = "x2= " & xItems(K)

xTarget.Offset(3, 0) = "Nearest sum= " & xSum

xTarget.Offset(4, 0) = "Distance= " & Format(Abs(XtargetVal - xSum), "0.00000")

xTarget.Offset(5, 0) = "% Distance of target= " & Format(Abs(XtargetVal - xSum) / XtargetVal, "0.00000%")

Exit Sub

End If

Lab_K:

Next K

Next J

' END 3. Two values that match exactly the target

' BEG Two values which when combined come within Percent of the target

For J = 1 To XitemMax

For K = J To XitemMax

'make the following line as comment line if twice 2,2 or 20,20 or 200,200 are allowed

If NoSameValues And xItems(J) = xItems(K) Then GoTo Lab_KK

xSum = xItems(J) + xItems(K)

If Abs(xSum - XtargetVal) <= XtargetVal * Percent Then

xTarget.Offset(1, 0) = "x1= " & xItems(J)

xTarget.Offset(2, 0) = "x2= " & xItems(K)

xTarget.Offset(3, 0) = "Nearest sum= " & xSum

xTarget.Offset(4, 0) = "Distance of target= " & Format(Abs(XtargetVal - xSum), "0.00000")

xTarget.Offset(5, 0) = "% Distance of target= " & Format(Abs(XtargetVal - xSum) / XtargetVal, "0.00000%")

Exit Sub

End If

Lab_KK:

Next K

Next J

' END Two values which when combined come within Percent of the target

' BEG Three values that match exactly

For J = 1 To XitemMax

For K = J To XitemMax

For M = K To XitemMax

'make the following line as comment line if twice 2,2 or 20,20 or 200,200 are allowed

If NoSameValues And (xItems(J) = xItems(K) Or xItems(J) = xItems(M) Or xItems(K) = xItems(M)) Then GoTo Lab_M

xSum = xItems(J) + xItems(K) + xItems(M)

If xSum = XtargetVal Then

xTarget.Offset(1, 0) = "x1= " & xItems(J)

xTarget.Offset(2, 0) = "x2= " & xItems(K)

xTarget.Offset(3, 0) = "x3= " & xItems(M)

xTarget.Offset(4, 0) = "Nearest sum= " & xSum

xTarget.Offset(5, 0) = "Distance= " & Format(Abs(XtargetVal - xSum), "0.00000")

xTarget.Offset(5, 0) = "% Distance of target= " & Format(Abs(XtargetVal - xSum) / XtargetVal, "0.00000%")

Exit Sub

End If

Lab_M:

Next M

Next K

Next J

' END Three values that match exactly

' BEG Three values that come within Percent of the target

For J = 1 To XitemMax

For K = J To XitemMax

For M = K To XitemMax

'make the following line as comment line if twice 2,2 or 20,20 or 200,200 are allowed

If NoSameValues And (xItems(J) = xItems(K) Or xItems(J) = xItems(M) Or xItems(K) = xItems(M)) Then GoTo Lab_MM

xSum = xItems(J) + xItems(K) + xItems(M)

If Abs(xSum - XtargetVal) <= XtargetVal * Percent Then

xTarget.Offset(1, 0) = "x1= " & xItems(J)

xTarget.Offset(2, 0) = "x2= " & xItems(K)

xTarget.Offset(3, 0) = "x3= " & xItems(M)

xTarget.Offset(4, 0) = "Nearest sum= " & xSum

xTarget.Offset(5, 0) = "Distance= " & Format(Abs(XtargetVal - xSum), "0.00000")

xTarget.Offset(6, 0) = "% Distance of target= " & Format(Abs(XtargetVal - xSum) / XtargetVal, "0.00000%")

Exit Sub

End If

Lab_MM:

Next M

Next K

Next J

' END Three values that come within Percent of the target

End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Gyzmo avait énoncé :