Find combinations of numbers that fit within a range.

RasmusAa · Jul 31, 2017

Hi All

When I was looking on the internet for a macro to solve my problem, I found an awesome one, which I pasted below. Now it just needs a little change to make it perfect for my purpose.

The macro is for matching numbers. If you have a lot of numbers (column b), and want to find a combination of n number(F3) to add up to a specific amount(F2) [FONT=&quot][/FONT] for that it works perfect.

I want to use this macro for accounting when finding incoming payments to match a number. The problem is that the incoming payments never fit the number 100%, due to small differences caused by fluctuating exchange rates.

What I want, is to find a way to implement [FONT=&quot][/FONT]a range[FONT=&quot][/FONT] for the number to find. Let[FONT=&quot][/FONT]s say the number I am looking for is 1000 USD, but due the small differences, the range I am looking for is 995 UDS to 1005 USD.

My hope is that I can type in 995 ([FONT=&quot][/FONT]lower range[FONT=&quot][/FONT]) in one cell (fx F25), and 1005 in another cell (F26,[FONT=&quot][/FONT]higher range[FONT=&quot][/FONT]), and then find the combinations that fit the criteria.

I am pretty new to VBA, and I can[FONT=&quot][/FONT]t get my head around this.

All suggestions are welcome

English is not my main language, but I hope you understand my question.

/Rasmus

Code:

Dim INV() As Currency
Dim CHECK As Currency
Dim MAX_CHECK_INVS_No As Integer
Dim Sol As Long
Dim RESUME_No() As Integer
Dim RES_No As Integer
Dim RESUME_CALC As Integer
Dim MAX_RESUME_No As Integer
Dim AA As Long
Dim MAX_INVS As Integer
Dim MAX_DEPTH As Integer
Dim Sol1 As Boolean
Dim Sol2 As Long
Dim Sol3 As Long
Dim SOLUTIONS() As String
Dim UPDATE_SOLUTION As Integer

Sub Challenge()

UPDATE_SOLUTION = Val(Cells(22, 6))
If UPDATE_SOLUTION < 0 Then UPDATE_SOLUTION = 100


' SORTING
Columns("B:B").Select
    Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlNo, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

' CLEAR SOLUTION AREA

Columns("H:H").Select
Selection.ClearContents

Columns("M:P").Select
Selection.ClearContents

Cells(11, 4).Select
Selection.Activate

Cells(18, 6) = 0
Cells(7, 6) = 0
CHECK = Cells(2, 6)

TOT_INV = Cells(1, 6)
ReDim INV(TOT_INV + 1)

MaxSum = 0

For i = 1 To TOT_INV
   INV(i) = Cells(i, 2)
   MaxSum = MaxSum + INV(i)
Next

SUM_INV = 0

MAX_INVS = 0

For i = 1 To TOT_INV
   SUM_INV = SUM_INV + INV(i)
   If SUM_INV = CHECK Then MAX_INVS = i: Exit For
   If SUM_INV > CHECK Then MAX_INVS = i - 1: Exit For
Next

Cells(3, 6) = MAX_INVS

MAX_CHECK_INVS_No = 1
i = 1

For i = TOT_INV To 2 Step -1
    SUM_INV = INV(i)
    If SUM_INV = CHECK Then GoTo Exit_for
    For k = 1 To i
        SUM_INV = SUM_INV + INV(k)
        If SUM_INV <= CHECK Then
           GoTo Exit_for
        End If
    Next
Next

Exit_for:
MAX_CHECK_INVS_No = i

INV(MAX_CHECK_INVS_No + 1) = MaxSum

Cells(4, 6) = MAX_CHECK_INVS_No

Sol = 0
AA = 0

Cells(14, 6) = Time

Application.ScreenUpdating = False

Sol1 = True: Sol2 = 21: Sol3 = 100

    Range("F14,F15,F16,F18,F19").Select
    Selection.NumberFormat = "h:mm:ss;@"
    Range("F23").Activate

    Find_Sol 0, "", 0
    
    Cells(10, 5) = Str(MAX_CHECK_INVS_No)
    Cells(15, 6) = Now()
    Cells(5, 6) = Sol
    
Application.ScreenUpdating = True

End Sub
    
Sub Find_Sol(No_01 As Integer, NN_01 As String, SINVS_01 As Currency)
 
For No_02% = No_01 + 1 To MAX_CHECK_INVS_No
    
    NN_02$ = NN_01 + Str(No_02%)
    SINVS_02@ = SINVS_01 + INV(No_02%)
                
    If SINVS_02@ > CHECK And CHECK > 0 Then Exit For
    If SINVS_02@ = CHECK Then
       Sol = Sol + 1
       If Sol > 65536 Then Sol = 1: COPY_SOLUTIONS
       
       Cells(Sol, 8) = NN_02$
             
       If Sol Mod UPDATE_SOLUTION = 0 Then
          Cells(10, 5) = NN_02$
          Cells(5, 6) = Sol
          Cells(15, 6) = Now()
          
          Cells(11, 6) = Print_No(NN_02$, MAX_CHECK_INVS_No)
          
          Application.ScreenUpdating = True
          Application.ScreenUpdating = False
       End If
     GoTo END_LOOP
    End If
    
        
    If SINVS_02@ + INV(No_02% + 1) > CHECK And CHECK > 0 Then
          
       If INV(No_02%) = INV(No_02% + 1) Then GoTo END_LOOP
       
       MAX_No_01% = MAX_CHECK_INVS_No + 1
       No_02% = No_02% + 1
       
START_LOOP:
      
       CH_No% = MAX_No_01% - No_02%
       
       If CH_No% > 1 Then
          CH_No_m% = CH_No% / 2 + No_02%
      
          If SINVS_01 + INV(CH_No_m%) > CHECK Then
             MAX_No_01% = CH_No_m%
             GoTo START_LOOP
          End If
          If SINVS_01 + INV(CH_No_m%) = CHECK Then
             No_02% = No_02% - 1
          End If
          If SINVS_01 + INV(CH_No_m%) < CHECK Then
             No_02% = CH_No_m% + 1
             GoTo START_LOOP
          End If
        Else
          If CH_No% = 1 Then
             If SINVS_01 + INV(MAX_No_01% - 1) = CHECK Then
                Sol = Sol + 1
              
              If Sol Mod UPDATE_SOLUTION = 0 Then
                 
                 Cells(10, 5) = NN_01 + Str(MAX_No_01% - 1)
                 Cells(5, 6) = Sol
                 Cells(15, 6) = Now()
                 Cells(11, 6) = Print_No(NN_02$, MAX_CHECK_INVS_No)
                 Application.ScreenUpdating = True
                 Application.ScreenUpdating = False
                 
              End If
                
                If Sol > 65536 Then Sol = 1: COPY_SOLUTIONS
                   Cells(Sol, 8) = NN_01 + Str(MAX_No_01% - 1)
                   Exit For
                End If
             End If
             Exit For
          End If
       End If
END_LOOP:
    
    Find_Sol No_02%, NN_02$, SINVS_02@
   
Next_No_02:
Next No_02

End Sub


Sub RESUME_LAST_SOLUTION()

TOT_INV = Cells(1, 6)

ReDim RESUME_No(TOT_INV)

LAST_SOLUTION_No = Cells(5, 6)
If LAST_SOLUTION_No = 0 Then Exit Sub
LAST_SOLUTION = Cells(LAST_SOLUTION_No, 8)

Range("D:D").Select
Selection.ClearContents

If LAST_SOLUTION <> "" Then

LAST_SOLUTION = Trim(LAST_SOLUTION) + " "

SOL_LEN = Len(LAST_SOLUTION)
START_LEN = 1

AA = 1
For i = START_LEN To SOL_LEN

No = InStr(i, LAST_SOLUTION, " ")

Cells(AA, 4) = Mid(LAST_SOLUTION, i, No - i)
RESUME_No(AA) = Cells(AA, 4)
i = No
AA = AA + 1

Next

End If


End Sub
Sub COPY_SOLUTIONS()

AC_NAME = ActiveSheet.Name

N = 0
SOL_NAME = Cells(2, 6)

Do
  N = N + 1
  SOL_NAME_01 = Trim(Str(SOL_NAME)) + "_" + Trim(Str(N))
Loop Until Exist_SHEET(SOL_NAME_01) = 0

Cells(7, 6) = N

Create_SOLUTIONS_PAGE (SOL_NAME_01)

Sheets(AC_NAME).Select
Range("H1:I65536").Select
Selection.Copy

Sheets(SOL_NAME_01).Select
Range("B1").Select
ActiveSheet.Paste
Columns("B:C").AutoFit
Range("B1").Select

Sheets(AC_NAME).Select
Range("H1:I65536").Select
Selection.ClearContents
Range("E10").Activate

End Sub
Function Exist_SHEET(SH_NAME)

Exist_SHEET = 0

For Each SH In Sheets
    If SH.Name = SH_NAME Then Exist_SHEET = 1: Exit For
Next SH
 
End Function

Sub Create_SOLUTIONS_PAGE(SH_NAME)

If Exist_SHEET(SH_NAME) Then
   Else
       Set NewSheet = Worksheets.Add
       NewSheet.Name = SH_NAME
End If

End Sub

Sub RESUME_Challenge()

If Cells(5, 6) = 0 Then Exit Sub

UPDATE_SOLUTION = Val(Cells(22, 6))
If UPDATE_SOLUTION < 0 Then UPDATE_SOLUTION = 100


' SORTING
Columns("B:B").Select
    Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlNo, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

RESUME_LAST_SOLUTION

RESUME_CALC = 1

Cells(11, 4).Select
Selection.Activate

MAX_RESUME_No = Cells(8, 6)

CHECK = Cells(2, 6) * 1000

TOT_INV = Cells(1, 6)
ReDim INV(TOT_INV + 1)

MaxSum = 0
For i = 1 To TOT_INV
    INV(i) = Cells(i, 2) * 1000
    MaxSum = MaxSum + INV(i)
Next

SUM_INV = 0

MAX_INVS = 0

For i = 1 To TOT_INV
   SUM_INV = SUM_INV + INV(i)
   If SUM_INV = CHECK Then MAX_INVS = i: Exit For
   If SUM_INV > CHECK Then MAX_INVS = i - 1: Exit For
Next

Cells(3, 6) = MAX_INVS

MAX_CHECK_INVS_No = 1

For i = TOT_INV To 2 Step -1
    SUM_INV = INV(i)
    If SUM_INV = CHECK Then GoTo Exit_for
    For k = 1 To i
        SUM_INV = SUM_INV + INV(k)
        If SUM_INV <= CHECK Then
           GoTo Exit_for
        End If
    Next
Next_i:
Next
Exit_for:
MAX_CHECK_INVS_No = i
INV(MAX_CHECK_INVS_No + 1) = MaxSum

Cells(4, 6) = MAX_CHECK_INVS_No

CHECK = MaxSum * 2
RES_No = 0
Sol = Cells(5, 6)

Cells(18, 6).Value = Cells(19, 6).Value

Cells(14, 6) = Time
No_01% = RESUME_No(1)

Application.ScreenUpdating = False
ReDim SOLUTIONS(100000)

    Range("F14,F15,F16,F18,F19").Select
    Selection.NumberFormat = "h:mm:ss;@"
    Range("F23").Activate

    RESUME_Find_Sol No_01%, "", 0

    Cells(10, 5) = Str(MAX_CHECK_INVS_No)
    Cells(15, 6) = Now()
    Cells(5, 6) = Sol
    
Application.ScreenUpdating = True

End Sub
    
Sub RESUME_Find_Sol(No_01 As Integer, NN_01 As String, SINVS_01 As Currency)
    
For No_02% = No_01 + 1 To MAX_CHECK_INVS_No
    
    If RESUME_CALC = 1 Then
       RES_No = RES_No + 1
       If RES_No > MAX_RESUME_No Then
             RESUME_CALC = 2
             CHECK = Cells(2, 6) * 1000
             No_02% = No_02% - 1
             Exit For
         Else
            No_02% = RESUME_No(RES_No)
       End If
    End If
    

    NN_02$ = NN_01 + Str(No_02%)
    SINVS_02@ = SINVS_01 + INV(No_02%)
    
    If SINVS_02@ > CHECK And CHECK > 0 Then Exit For
    If SINVS_02@ = CHECK Then
       Sol = Sol + 1
       If Sol > 65536 Then Sol = 1: COPY_SOLUTIONS
       
       Cells(Sol, 8) = NN_02$
                 
       If Sol Mod UPDATE_SOLUTION = 0 Then
          Cells(10, 5) = NN_02$
          Cells(5, 6) = Sol
          Cells(15, 6) = Now()
          Cells(11, 6) = Print_No(NN_02$, MAX_CHECK_INVS_No)
          Application.ScreenUpdating = True
          Application.ScreenUpdating = False
       End If
                 
                 
    End If
        
    If SINVS_02@ + INV(No_02% + 1) > CHECK Then
           
       If INV(No_02%) = INV(No_02% + 1) Then GoTo END_LOOP
       
       MAX_No_01% = MAX_CHECK_INVS_No + 1
       No_02% = No_02% + 1
       
START_LOOP:
      
       CH_No% = MAX_No_01% - No_02%
       
       If CH_No% > 1 Then
          CH_No_m% = CH_No% / 2 + No_02%
      
          If SINVS_01 + INV(CH_No_m%) > CHECK Then
             MAX_No_01% = CH_No_m%
             GoTo START_LOOP
          End If
          If SINVS_01 + INV(CH_No_m%) = CHECK Then
             No_02% = No_02% - 1
          End If
          If SINVS_01 + INV(CH_No_m%) < CHECK Then
             No_02% = CH_No_m% + 1
             GoTo START_LOOP
          End If
        Else
          If CH_No% = 1 Then
             If SINVS_01 + INV(MAX_No_01% - 1) = CHECK Then
                Sol = Sol + 1
               
               If Sol Mod UPDATE_SOLUTION = 0 Then
                 Cells(10, 5) = NN_01 + Str(MAX_No_01% - 1)
                 Cells(5, 6) = Sol
                 Cells(15, 6) = Now()
                 Cells(11, 6) = Print_No(NN_02$, MAX_CHECK_INVS_No)
                 Application.ScreenUpdating = True
                 Application.ScreenUpdating = False
              End If
              
                
                If Sol > 65536 Then Sol = 1: COPY_SOLUTIONS
                   Cells(Sol, 8) = NN_01 + Str(No_02%)
                  Exit For
                End If
             End If
             Exit For
          End If
       End If
END_LOOP:
         
    RESUME_Find_Sol No_02%, NN_02$, SINVS_02@

Next_No_02:
Next No_02

End Sub

Find combinations of numbers that fit within a range.

RasmusAa

New Member

Excel Facts

Similar threads

Forum statistics

Share this page

Find combinations of numbers that fit within a range.

RasmusAa

New Member

Excel Facts

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock