VBA required to total numbers to match closest to target (complex one...)

[Gyzmo]

I have a range of numbers as follows (sheet2, A1:A30):

1, 2, 2, 5, 10, 20, 20, 50, 100, 200, 200, 500, 1000 (and so on)

The user enters an integer (in cell B1) to be matched, however.....

The number entered by the user needs to be rounded to the nearest
value that can be obtained by combining any of two numbers from the
range given above, and the two values used returned.

A couple of examples:

If the user enters 10, then 10 should be selected.
If the user enters 15, then 10 and 5 should be selected.
If the user enters 13, then 10 and 5 should be selected.

A couple of complications:
1. Only addition can be used to reach the target value.
2. You will see that there are two lots of numbers that begin with 2
(2, 20, 200 etc). Where one of these is to be used (not both), then
only the first of the two is to be used (the reason is that each
individual one is connected to other values that are unique and will
be referred to).
3. The whole thing is to be done automatically - no highlighting of
ranges or anything like that.

I've really really tried, but can't manage to even begin working it
out. If anyone can help I'd be really grateful.

 

[Gyzmo]

Correction - in the second example, (using 13), 10 and 2 should be
selected, not 10 and 5.

 

[Charabeuh]

Hello Gyzmo,

1°) Name your range (A1:A30) : Items
2°) Name your cell (B1) : Target
3°) I assumes your range is sorted from the rhe smallest to largest
4°) The result will be displayed in cells(B2:B5)

The try this code in a module:
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub NearestOneOrTwo()

Dim xItems As Range, XitemMax As Long
Dim xTarget As Range, XtargetVal
Dim xNbElemMax As Long, xNbelem As Long
Dim J As Long, K As Long, xIndex As Long
Dim xDistance As Single

Set xItems = Range("Items")
Set xTarget = Range("Target")
XtargetVal = Range("Target").Value

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")
Exit Sub
End If
Next J

If XtargetVal < xItems(1) + xItems(2) Then
MsgBox "Number too small"
Exit Sub
End If

XitemMax = Application.Evaluate("=MATCH(Target,Items,1)")
xNbElemMax = XitemMax * (XitemMax + 1) / 2

ReDim xelem(xNbElemMax, 3)

For J = 1 To XitemMax
If J > 1 Then
If xItems(J) = xItems(J - 1) Then GoTo Lab_J
End If
For K = J + 1 To XitemMax
If (xItems(K) <> xItems(K - 1)) And (xItems(K) + xItems(J) <= XtargetVal) Then
xNbelem = xNbelem + 1
xelem(xNbelem, 1) = xItems(J).Value + xItems(K).Value
xelem(xNbelem, 2) = xItems(J).Value
xelem(xNbelem, 3) = xItems(K).Value
End If
Next K
Lab_J:
Next J

xDistance = Abs(xelem(1, 1) - XtargetVal)
xIndex = 1
For J = 2 To xNbelem
If Abs(xelem(J, 1) - XtargetVal) < xDistance Then
xDistance = Abs(xelem(J, 1) - XtargetVal)
xIndex = J
End If
Next J
xTarget.Offset(1, 0) = "x1= " & xelem(xIndex, 2)
xTarget.Offset(2, 0) = "x2= " & xelem(xIndex, 3)
xTarget.Offset(3, 0) = "Nearest sum= " & xelem(xIndex, 1)
xTarget.Offset(4, 0) = "Distance= " & Format(xDistance, "0.00000")

End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''






Le 05/03/2011, Gyzmo a supposé :

 

[Charabeuh]

Sorry !

I read your post too fast and my code find the larger sum that is
smaller than the value in B1.

I will correct this

 

[Charabeuh]

Try this code:
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub NearestOneOrTwo()

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
Dim xDistance As Single, xSum As Long

Set xItems = Range("Items")
Set xTarget = Range("Target")
XtargetVal = Range("Target").Value

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")
Exit Sub
End If
Next J

XitemMax = xItems.Count
xDistance = Abs(xItems(1) - XtargetVal)
xIndex1 = 1: xIndex2 = 2

For J = 1 To XitemMax
If J > 1 Then
If xItems(J) = xItems(J - 1) Then GoTo Lab_J
End If
For K = J + 1 To XitemMax
xSum = xItems(J).Value + xItems(K).Value
If Abs(xSum - XtargetVal) < xDistance Then
xIndex1 = J: xIndex2 = K
xDistance = Abs(xSum - XtargetVal)
End If
Next K
Lab_J:
Next J

xTarget.Offset(1, 0) = "x1= " & xItems(xIndex1)
xTarget.Offset(2, 0) = "x2= " & xItems(xIndex2)
xTarget.Offset(3, 0) = "Nearest sum= " & xItems(xIndex1) + xItems(xIndex2)
xTarget.Offset(4, 0) = "Distance= " & Format(Abs(xItems(xIndex1) + xItems(xIndex2) - XtargetVal), "0.00000")

End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Some explanation is missing:
if B1=99, is the result 100 a valid response or only 100+1?
(100 is nearer of 99 then 100+1).
In another words, is a single value also a correct answer ?

___________________________________________
Charabeuh a formulé la demande :

 

[Charabeuh]

I'm hungry. This is surely why I wrote stupid things.

To not take twice a value, replace this part of code:

For K = J + 1 To XitemMax
xSum = xItems(J).Value + xItems(K).Value
If Abs(xSum - XtargetVal) < xDistance Then
xIndex1 = J: xIndex2 = K
xDistance = Abs(xSum - XtargetVal)
End If
Next K

With this one:

For K = J + 1 To XitemMax
If xItems(K) <> xItems(K - 1) Then
xSum = xItems(J).Value + xItems(K).Value
If Abs(xSum - XtargetVal) < xDistance Then
xIndex1 = J: xIndex2 = K
xDistance = Abs(xSum - XtargetVal)
End If
End If
Next K

That should be the last one (I hope so!)

 

[Gyzmo]

Charabeuh, you are a genius!

Thank you so much - this has saved my days of work and headaches! I
would have replied sooner but have been away.

With regards to the example of 99, then 100 would be the preferred
target, so just the one value would be used. I suppose my explanation
isn't that clear.

When values such as 99, 85, 87 are the targets, I've noticed the
program selects two values 100 and 0.001. In these examples, just the
100 would be sufficient.

Also, Where the target is .004, .04, .4, 4, 40, 400 etc etc, then both
the corresponding values with a 2 should be used.

I think I'd better explain what this is being used for.

My job is to calibrate weights. To do this, we have a set of our own
weights (the weight (grams) values of which are those in the
range"items"). These are used to compare against the value of a
weight that is submitted for testing. By doing this the true mass of
the weight submitted can be determined.

You may notice that the values in the range "target" can be added to
achieve any number (so i you have 68 as a target, then 50, 10, 5, 2, 1
can be combined to reach the target. If the target is 69, then 50,
10, 5, 2, 2 can be combined).

In practice, however, we're limited to using one or two weights to
compare (any difference is extrapolated).

So if an unknown weight has a mass of 200g, then we'd use one of our
200g weights to compare. If it's 800, then we'd use a 500g weight and
a 200 g weight. If the unknown is, say, 400g, then we'd use both our
200g weights. If however it's 300g, then we'd use a 100 g weight and
a 200 g weight.

You'll notice that there are 2 lots of weights that contain the same
value (so two lots of 2g, two lots of 20g etc etc). These are
differentiated by a marking or by its shape so we know which one is
which. The reason is that the weights have their own values. A 2g
weight will not be exactly 2g, it will be off by a couple of
nanograms, and this needs to be taken into consideration when we do
our calculations. So our two weights of the same value (in this case,
the two 2g weights) will actually not weigh the same. Therefore, when
we only use one of them, it is always the same one and not the other
(which is why I needed to have the first of two of the same to be
selected).

I hope that makes sense and thanks again for your efforts. If you
could tell me how I adjust the program, I'd be very grateful.

 

[Charabeuh]

Hello,
Try This one:

Sub ClosestOneOrTwo5()

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Singles values are allowed
' (20..;20..) are OK for exact sum = 20.. + 20..
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

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
Dim xDistance As Single, xSum As Long

Set xItems = Range("Items")
Set xTarget = Range("Target")
XtargetVal = Range("Target").Value

' BEG: For exact single number only
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")
Exit Sub
End If
Next J
' END: For exact single number only


' BEG: For Number = 2.. + 2..
For J = 2 To xItems.Count
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 - xItems(J - 1) - xItems(J)), "0.00000")
Exit Sub
End If
Next J
' END: For Number = 2.. + 2..

' BEG: For Other combination
'initialization
XitemMax = xItems.Count
xDistance = Abs(xItems(1) - XtargetVal)
xIndex1 = 1: xIndex2 = 1

'LOOP
For J = 1 To XitemMax

If J > 1 Then
'refuse the same numbers
If xItems(J) = xItems(J - 1) Then GoTo Lab_J

' BEG: close single number
xSum = xItems(J).Value
If Abs(xSum - XtargetVal) < xDistance Then
xIndex1 = J: xIndex2 = J
xDistance = Abs(xSum - XtargetVal)
End If
' END: close single number
End If

For K = J + 1 To XitemMax
If xItems(K) <> xItems(K - 1) Then
xSum = xItems(J).Value + xItems(K).Value
If Abs(xSum - XtargetVal) < xDistance Then
xIndex1 = J: xIndex2 = K
xDistance = Abs(xSum - XtargetVal)
End If
End If
Next K

Lab_J:
Next J

If xIndex1 <> xIndex2 Then
xTarget.Offset(1, 0) = "x1= " & xItems(xIndex1)
xTarget.Offset(2, 0) = "x2= " & xItems(xIndex2)
xTarget.Offset(3, 0) = "Nearest sum= " & xItems(xIndex1) + xItems(xIndex2)
xTarget.Offset(4, 0) = "Distance= " & Format(Abs(xItems(xIndex1) + xItems(xIndex2) - XtargetVal), "0.00000")
Else
xTarget.Offset(1, 0) = "x1= " & xItems(xIndex1)
xTarget.Offset(2, 0) = "x2= "
xTarget.Offset(3, 0) = "Nearest sum= " & xItems(xIndex1)
xTarget.Offset(4, 0) = "Distance= " & Format(Abs(xItems(xIndex1) - XtargetVal), "0.00000")
End If

End Sub

 

[Charabeuh]

If you want for 85 the result 100 instead of (20+50), replace
(the "<" is replaced with "<=")


' BEG: close single number
xSum = xItems(J).Value
If Abs(xSum - XtargetVal) < xDistance Then
xIndex1 = J: xIndex2 = J
xDistance = Abs(xSum - XtargetVal)
End If
' END: close single number

With

' BEG: close single number
xSum = xItems(J).Value
If Abs(xSum - XtargetVal) <= xDistance Then
xIndex1 = J: xIndex2 = J
xDistance = Abs(xSum - XtargetVal)
End If
' END: close single number





Charabeuh a présenté l'énoncé suivant :

 

[Gyzmo]

Charabeuh, many thanks again.

I'm afraid though that I misunderstood what my manager wanted, and the
"rules" I got were wrong. It should be like this.

Order of preference.
1. 1 value that matches exactly with the target, else
2. 1 value that comes within 10% of the target, else
3. 2 values that match exactly the target else
4. 2 values which when combined come within 10% of the target
5. 3 values that match exactly or that come within 10% of the target.

Whether the value(s) are higher or lower than the target value doesn't
matter.
The rule about using 0.02, 2, 20 etc still applies.

I have tried adopting the code to do this, but I'm afraid its beyond
me. Would you (or anyone else) mind helping?

Many thanks again for everything so far.

 

[Charabeuh]

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é :

 

[Gyzmo]

Many thanks again for your help.

It should be possible to match the majority of values.

With 41 for example, then 20 + 20 would be the best match.

I've noticed with the code doesn't give results for some values,
notably for decimals like 1.6 (1 + 0.5) or 2.4 (2 + 0.5), though
results will come up for the likes of 16 (10 + 5) or 24 (20+2). It
also doesn't find results for anything belo 1.0 unless it is an exact
match).

I think the problem may be to do with the "duplicate" values. Whilst
the same cell in the range A1:A32 cannot be used twice, the same
number, if it is duplicated in the range, can.

So for example, with 4, it is OK to use 2 + 2 as there are two lots of
2. SImilarly, if it was 45, then 20 + 20 + 5 could be used. But it
should not be 1+1+1+1 for example, as there is only 1 actualy number
1.

If you imagine each cell in the range A1:A32 being a physical weight
that weighs the amount in that cell, and you have to combine them to
reach the target figure.

 

[Charabeuh]

Hello,

Hello,

Here is a code that will give you a set of solutions. You can choose the solution you want:
a) one, two or three values
b) according to exact match
c) or closest sum
d) within 10% of target value or not.


The code:
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub Closest123()

Dim xItems As Range, XitemMax As Long
Dim xTarget As Range, XtargetVal
Dim X1 As Long, X2 As Long, X3 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(2, 0).Resize(7, 4).Clear
xTarget.Offset(2, 0).Resize(7, 1).Interior.Color = RGB(215, 215, 215)
xTarget.Offset(2, 1).Resize(1, 3).Interior.Color = RGB(255, 255, 102)
xTarget.Offset(3, 1).Resize(1, 3).Interior.Color = RGB(255, 204, 102)
xTarget.Offset(4, 2).Resize(1, 2).Interior.Color = RGB(255, 204, 102)
xTarget.Offset(5, 3).Resize(1, 1).Interior.Color = RGB(255, 204, 102)
xTarget.Offset(6, 1).Resize(1, 3).Interior.Color = RGB(255, 204, 255)
xTarget.Offset(7, 1).Resize(1, 3).Interior.Color = RGB(153, 204, 153)
xTarget.Offset(8, 1).Resize(1, 3).Interior.Color = RGB(204, 204, 153)
xTarget.Offset(2, 0).Resize(7, 4).Borders.LineStyle = xlContinuous

xTarget.Offset(2, 0) = "Target "
xTarget.Offset(3, 0) = "X1"
xTarget.Offset(4, 0) = "X2"
xTarget.Offset(5, 0) = "X3"
xTarget.Offset(6, 0) = "Nearest sum"
xTarget.Offset(7, 0) = "Distance"
xTarget.Offset(8, 0) = "% Distance of target"

'BEG: Closest one value
xDistance = Abs(XtargetVal - xItems(1))
X1 = xItems(1)
For J = 1 To xItems.Count
If Abs(XtargetVal - xItems(J)) < xDistance Then
xDistance = Abs(XtargetVal - xItems(J))
X1 = xItems(J)
End If
Next J
xTarget.Offset(2, 1) = XtargetVal
xTarget.Offset(3, 1) = X1
xTarget.Offset(4, 1) = ""
xTarget.Offset(5, 1) = ""
xTarget.Offset(6, 1) = X1
xTarget.Offset(7, 1) = Format(xDistance, "0.00000")
xTarget.Offset(8, 1) = Format(xDistance / XtargetVal, "0.00000%")
' END: Closest one value

'BEG: Closest two values
xSum = xItems(1) + xItems(2)
xDistance = Abs(XtargetVal - xSum)
X1 = xItems(1): X2 = xItems(2)
For J = 1 To xItems.Count
For K = J + 1 To xItems.Count
xSum = xItems(J) + xItems(K)
If Abs(XtargetVal - xSum) < xDistance Then
xDistance = Abs(XtargetVal - xSum)
X1 = xItems(J): X2 = xItems(K)
End If
Next K
Next J
xTarget.Offset(2, 2) = XtargetVal
xTarget.Offset(3, 2) = X1
xTarget.Offset(4, 2) = X2
xTarget.Offset(5, 2) = ""
xTarget.Offset(6, 2) = X1 + X2
xTarget.Offset(7, 2) = Format(xDistance, "0.00000")
xTarget.Offset(8, 2) = Format(xDistance / XtargetVal, "0.00000%")
' END: Closest two values

'BEG: Closest three values
xSum = xItems(1) + xItems(2) + xItems(3)
xDistance = Abs(XtargetVal - xSum)
X1 = xItems(1): X2 = xItems(2): X3 = xItems(3)
For J = 1 To xItems.Count
For K = J + 1 To xItems.Count
For M = K + 1 To xItems.Count
xSum = xItems(J) + xItems(K) + xItems(M)
If Abs(XtargetVal - xSum) < xDistance Then
xDistance = Abs(XtargetVal - xSum)
X1 = xItems(J): X2 = xItems(K): X3 = xItems(M)
End If
Next M
Next K
Next J
xTarget.Offset(2, 3) = XtargetVal
xTarget.Offset(3, 3) = X1
xTarget.Offset(4, 3) = X2
xTarget.Offset(5, 3) = X3
xTarget.Offset(6, 3) = X1 + X2 + X3
xTarget.Offset(7, 3) = Format(xDistance, "0.00000")
xTarget.Offset(8, 3) = Format(xDistance / XtargetVal, "0.00000%")
' END: Closest three values

xTarget.Offset(2, 0).Resize(7, 4).Columns.AutoFit
xTarget.Offset(2, 1).Resize(7, 3).Columns.ColumnWidth = _
2 * xTarget.Offset(2, 1).Resize(7, 3).Columns(1).ColumnWidth

End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''



Gyzmo a utilisé son clavier pour écrire :

 

[Gyzmo]

Hello Again,

The code still seems to have problems with decimals.

for example, 0.02 does not give any match, and 1.25 matches only 1
(whereas it could match 1, 0.2 and 0.05).

I've realised that my first post mentions the range 1 to 20000. The
actual number is the range start at 0.001 and end at 20000. I thought
that it wouldn't really matter but it seems it may do. I do
apologise, my knowledge of VBA is quite limited.

 

[Charabeuh]

Hello,

Since your weights can be decimal, try the following code:
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub Closest123()

Dim xItems As Range, XitemMax As Long
Dim xTarget As Range, XtargetVal
Dim X1 As Single, X2 As Single, X3 As Single
Dim J As Long, K As Long, M As Long
Dim xDistance As Single, xSum As Single

Application.ScreenUpdating = False
Set xItems = Range("Items")
XitemMax = xItems.Cells.Count
Set xTarget = Range("Target")
XtargetVal = Range("Target").Value

xTarget.Offset(2, 0).Resize(7, 4).Clear
xTarget.Offset(2, 0).Resize(7, 1).Interior.Color = RGB(215, 215, 215)
xTarget.Offset(2, 1).Resize(1, 3).Interior.Color = RGB(255, 255, 102)
xTarget.Offset(3, 1).Resize(1, 3).Interior.Color = RGB(255, 204, 102)
xTarget.Offset(4, 2).Resize(1, 2).Interior.Color = RGB(255, 204, 102)
xTarget.Offset(5, 3).Resize(1, 1).Interior.Color = RGB(255, 204, 102)
xTarget.Offset(6, 1).Resize(1, 3).Interior.Color = RGB(255, 204, 255)
xTarget.Offset(7, 1).Resize(1, 3).Interior.Color = RGB(153, 204, 153)
xTarget.Offset(8, 1).Resize(1, 3).Interior.Color = RGB(204, 204, 153)
xTarget.Offset(2, 0).Resize(7, 4).Borders.LineStyle = xlContinuous

xTarget.Offset(2, 0) = "Target "
xTarget.Offset(3, 0) = "X1"
xTarget.Offset(4, 0) = "X2"
xTarget.Offset(5, 0) = "X3"
xTarget.Offset(6, 0) = "Nearest sum"
xTarget.Offset(7, 0) = "Distance"
xTarget.Offset(8, 0) = "% Distance of target"

xTarget.Offset(2, 1).Resize(6, 3).NumberFormat = "# ##0.000"

'BEG: Closest one value
xDistance = Abs(XtargetVal - xItems(1))
X1 = xItems(1)
For J = 1 To xItems.Count
If Abs(XtargetVal - xItems(J)) < xDistance Then
xDistance = Abs(XtargetVal - xItems(J))
X1 = xItems(J)
End If
Next J
xTarget.Offset(2, 1) = XtargetVal
xTarget.Offset(3, 1) = X1
xTarget.Offset(4, 1) = ""
xTarget.Offset(5, 1) = ""
xTarget.Offset(6, 1) = X1
xTarget.Offset(7, 1) = Format(xDistance, "0.00000")
xTarget.Offset(8, 1) = Format(xDistance / XtargetVal, "0.00000%")
' END: Closest one value

'BEG: Closest two values
xSum = xItems(1) + xItems(2)
xDistance = Abs(XtargetVal - xSum)
X1 = xItems(1): X2 = xItems(2)
For J = 1 To xItems.Count
For K = J + 1 To xItems.Count
xSum = xItems(J) + xItems(K)
If Abs(XtargetVal - xSum) < xDistance Then
xDistance = Abs(XtargetVal - xSum)
X1 = xItems(J): X2 = xItems(K)
End If
Next K
Next J
xTarget.Offset(2, 2) = XtargetVal
xTarget.Offset(3, 2) = X1
xTarget.Offset(4, 2) = X2
xTarget.Offset(5, 2) = ""
xTarget.Offset(6, 2) = X1 + X2
xTarget.Offset(7, 2) = Format(xDistance, "0.00000")
xTarget.Offset(8, 2) = Format(xDistance / XtargetVal, "0.00000%")
' END: Closest two values

'BEG: Closest three values
xSum = xItems(1) + xItems(2) + xItems(3)
xDistance = Abs(XtargetVal - xSum)
X1 = xItems(1): X2 = xItems(2): X3 = xItems(3)
For J = 1 To xItems.Count
For K = J + 1 To xItems.Count
For M = K + 1 To xItems.Count
xSum = xItems(J) + xItems(K) + xItems(M)
If Abs(XtargetVal - xSum) < xDistance Then
xDistance = Abs(XtargetVal - xSum)
X1 = xItems(J): X2 = xItems(K): X3 = xItems(M)
End If
Next M
Next K
Next J
xTarget.Offset(2, 3) = XtargetVal
xTarget.Offset(3, 3) = X1
xTarget.Offset(4, 3) = X2
xTarget.Offset(5, 3) = X3
xTarget.Offset(6, 3) = X1 + X2 + X3
xTarget.Offset(7, 3) = Format(xDistance, "0.00000")
xTarget.Offset(8, 3) = Format(xDistance / XtargetVal, "0.00000%")
' END: Closest three values

xTarget.Offset(2, 0).Resize(7, 4).Columns.AutoFit
xTarget.Offset(2, 1).Resize(7, 3).Columns.ColumnWidth = _
2 * xTarget.Offset(2, 1).Resize(7, 3).Columns(1).ColumnWidth
Application.ScreenUpdating = True

End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


Gyzmo a émis l'idée suivante :