** PLEASE DO NOT REPLY TO THIS MESSAGE**
This is to demonstrate the principle for solving a common problem.
It is necessary to have a separate subroutine to test different size sets of numbers. So if a total is not matched by adding 2 numbers the macro goes on to try 3,4,5 etc.
As the size of set increases so does the run time. This obviously depends on how many numbers in the list. With around 100 numbers and checking sets of numbers bigger than 4 you probably need an overnight run. Some time can be save by ordering the numbers. eg. if searching for a negative number have all negative numbers at the top of the list.
This is to demonstrate the principle for solving a common problem.
It is necessary to have a separate subroutine to test different size sets of numbers. So if a total is not matched by adding 2 numbers the macro goes on to try 3,4,5 etc.
As the size of set increases so does the run time. This obviously depends on how many numbers in the list. With around 100 numbers and checking sets of numbers bigger than 4 you probably need an overnight run. Some time can be save by ordering the numbers. eg. if searching for a negative number have all negative numbers at the top of the list.
Code:
'=== copy from here to the end =======================
'- MACRO TO FIND A 3 NUMBER SET IN A LIST
'- TO MAKE A GIVEN TOTAL
'- Check total in cell A1 - other numbers A2 down
'- add loops to adapt to different size sets
'- results put to column B
'- Brian Baulsom January 2003
'=====================================================
Option Base 1
Dim NumberSheet As Worksheet
Dim NumberList() As Variant ' array of values
Dim N1 As Long
Dim N2 As Long
Dim N3 As Long
Dim LastRow As Long
Dim MyRow As Long
Dim CheckNumber As Double
Dim CheckSum As Double
Dim SetFound As Boolean
'========================================================
'- MAIN ROUTINE
'========================================================
Sub FIND_NUMBERS()
Application.Calculation = xlCalculationManual
Set NumberSheet = ActiveSheet
'----------------------------------------------------
'- checksum in cell A1
CheckNumber = NumberSheet.Range("A1").Value
'----------------------------------------------------
'- number array
LastRow = NumberSheet.Range("A65536").End(xlUp).Row
ReDim NumberList(LastRow)
For r = 1 To LastRow
NumberList(r) = NumberSheet.Cells(r + 1, 1).Value
Next
'-----------------------------------------------------
'- loops - try 2 numbers (not shown), then 3 ... etc.
'SET2 (suboutine not here)
'If SetFound = True Then GoTo GetOut
'-----------------------------------
SET3 ' run subroutine
If SetFound = True Then GoTo GetOut
'-----------------------------------------------------
MsgBox ("Total not found.")
GetOut:
Application.StatusBar = False
Application.Calculation = xlCalculationAutomatic
End Sub
'------------------------------------------------------------
'============================================================
'- SUBROUTINE TO FIND 3 NUMBERS THAT MAKE UP THE TOTAL
'============================================================
Private Sub SET3()
SetFound = False
For N1 = 1 To LastRow
For N2 = N1 + 1 To LastRow
For N3 = N2 + 1 To LastRow
'---------------------------------------------------
'- check total
Application.StatusBar = _
" 3 Numbers " & N1 & ":" & N2 & ":" & N3
CheckSum = _
NumberList(N1) + NumberList(N2) + NumberList(N3)
'---------------------------------------------------
'- change the next line according to the closeness of match required
If Abs(CheckNumber - CheckSum) < 1 Then '
NumberSheet.Range("B1").Value = NumberList(N1)
NumberSheet.Range("B2").Value = NumberList(N2)
NumberSheet.Range("B3").Value = NumberList(N3)
MsgBox ("Please see results in column B")
SetFound = True
Exit Sub
End If
'---------------------------------------------------
Next N3
Next N2
Next N1
End Sub
'-------------------------------------------------------------------
'== copy down to here ==============================================
