|
TRaP
Moderator
Inregistrat: acum 7 ani
Postari: 863
|
|
I needed a VBA solver similar to the Solver add-in in Excel, but that works faster and with decimals. Solver tends to find numbers close to the total I need, and I didn't spend time to configure it very much to give me exact results.
Anyway, below is a VBA macro built with ChatGPT that found the desired number combination in 1 second (or less).
This solver does the following:
✅ automatic deletion of old “Combinations” sheet (if exists from previous calculation)
✅ range of numbers to combine and total required value input via InputBoxes
✅ formatted output (headings, alignment)
✅ the requested total shown at the top
✅ per-combination totals displayed and verified
✅ highlighting of cells in the original range that form part of any found combination
Later edit by Mrrrr:
✅ prompts for the error margin (tolerance) via an InputBox (e.g. “0,1” → ±0,1 range)
✅ added a Yes/No prompt to choose between exact match or within margin
✅ if user selects Exact match, it uses margin = 0,001 for precision
✅ if user selects With margin, asks for the numeric margin
✅ if margin = 0, it finds all possible combinations (no filtering)
✅ if margin ≠ 0, it stops after 30 combinations and shows a message to refine margin to get less combinations
Sub VBA_Solver()
Dim wsComb As Worksheet
Dim wsSource As Worksheet
Dim rng As Range
Dim cell As Range
Dim numbers() As Double
Dim target As Double
Dim margin As Double
Dim n As Long, i As Long, j As Long
Dim resultCount As Long
Dim combo() As Long
Dim currentSum As Double
Dim colOffset As Long
Dim combinationTotalRow As Long
Dim searchMode As VbMsgBoxResult
Dim stopSearch As Boolean
'--- Ask for range
On Error Resume Next
Set rng = Application.InputBox("Select the range of numbers:", "Select Range", Type:=8)
If rng Is Nothing Then Exit Sub
On Error GoTo 0
'--- Ask for target total
target = Application.InputBox("Enter the target total:", "Target Total", Type:=1)
If target = 0 And StrPtr(target) = 0 Then Exit Sub
'--- Ask whether to use margin
searchMode = MsgBox("Do you want to use an error margin (± tolerance)?", vbYesNo + vbQuestion, "Search Mode")
If searchMode = vbYes Then
margin = Application.InputBox("Enter allowed error margin (e.g., 0.1 for ±0.1):", "Error Margin", Type:=1)
If margin < 0 Then margin = Abs(margin)
Else
margin = 0.001 ' small tolerance for floating point precision
End If
Set wsSource = rng.Worksheet
'--- Delete old "Combinations" sheet if it exists
Application.DisplayAlerts = False
On Error Resume Next
ThisWorkbook.Worksheets("Combinations").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'--- Create new sheet
Set wsComb = ThisWorkbook.Worksheets.Add
wsComb.Name = "Combinations"
'--- Store numbers into array
n = rng.Count
ReDim numbers(1 To n)
i = 1
For Each cell In rng
numbers(i) = cell.Value
i = i + 1
Next cell
'--- Write source numbers in column A
wsComb.Cells(1, 1).Value = "Source Range: " & rng.Address(External:=True)
wsComb.Cells(2, 1).Value = "Requested Total:"
wsComb.Cells(2, 2).Value = target
wsComb.Cells(3, 1).Value = "Allowed Error Margin (±):"
wsComb.Cells(3, 2).Value = IIf(searchMode = vbYes, margin, "Exact match")
wsComb.Cells(5, 1).Value = "Numbers"
For i = 1 To n
wsComb.Cells(i + 5, 1).Value = numbers(i)
Next i
'--- Prepare search
resultCount = 0
combinationTotalRow = n + 7
colOffset = 2
stopSearch = False
'--- Search for combinations (bitmask)
For i = 1 To (2 ^ n) - 1
ReDim combo(1 To n)
currentSum = 0
For j = 1 To n
If (i And (2 ^ (j - 1))) <> 0 Then
currentSum = currentSum + numbers(j)
combo(j) = 1
End If
Next j
'--- Evaluate combination
If margin = 0 Then
' Margin = 0 ? show all combinations
resultCount = resultCount + 1
ElseIf Abs(currentSum - target) <= margin Then
resultCount = resultCount + 1
End If
'--- Save combination if it meets criteria
If (margin = 0) Or (Abs(currentSum - target) <= margin) Then
wsComb.Cells(5, colOffset + resultCount - 1).Value = "Combination " & resultCount
For j = 1 To n
If combo(j) = 1 Then
wsComb.Cells(j + 5, colOffset + resultCount - 1).Value = numbers(j)
' Highlight source range cells
rng.Cells(j).Interior.Color = RGB(255, 255, 150)
End If
Next j
wsComb.Cells(combinationTotalRow, colOffset + resultCount - 1).Formula = _
"=SUM(" & wsComb.Range(wsComb.Cells(6, colOffset + resultCount - 1), _
wsComb.Cells(5 + n, colOffset + resultCount - 1)).Address(False, False) & ")"
End If
'--- Stop after 30 if margin ? 0
If margin <> 0 And resultCount >= 30 Then
stopSearch = True
Exit For
End If
Next i
'--- Formatting
With wsComb
.Cells(5, 1).Font.Bold = True
.Rows(5).Font.Bold = True
.Rows(5).HorizontalAlignment = xlCenter
.Columns("A:" & Chr(64 + colOffset + resultCount)).AutoFit
.Cells(combinationTotalRow, 1).Value = "Total per combination:"
.Cells(combinationTotalRow, 1).Font.Bold = True
End With
'--- Messages
If margin = 0 Then
MsgBox resultCount & " total combination(s) listed (margin = 0 ? all shown).", vbInformation
ElseIf stopSearch Then
MsgBox "More than 30 combinations found. Please refine your error margin." & vbCrLf & _
"If you want all combinations, click Yes and add margin: 0", vbExclamation
Else
MsgBox resultCount & " combination(s) found within ±" & margin & " of target " & target, vbInformation
End If
End Sub |
Source:
ChatGPT
|
|
