VBA for summing numbers in combinations to match a target value (but not specific a range)

[SamyW]

Hi There,

I am new to this forum, I really need some one's help for the below problem,

I have a workbook with 4 columns, coloumn A has a region name, coloumn B has a school name, column c has the subject name and coloumn D has the number of books to be delivered to each of these schools.

What i need the vba programme to do is try different combinations for summing the numbers in coloumn D to return combinations (not repeating the same number) that equals to a value that lies in a specific range.

Say the maximum number of books i can pack in a box 30, the vba should return me the combinations of values from coloumn D to equal to the value between 26-30

Each school have 14 subjects, so basically i will devide the data of 6500 rows to school wise.

Any help would be much apprecited.... thanks in advance!!!!!

Region	School name	Subject	Number of books
DXB	A	English	13
DXB	A	Mathematics	10
DXB	A	History	1
DXB	A	Geography	7
DXB	A	Physics	5
DXB	A	Chemistry	4
DXB	A	Language	12
DXB	A	Craft	11
DXB	A	economics	2
DXB	A	statics	1

<TBODY>
</TBODY>

 

[craig.penny]

Hi SamyW and welcome

I wrote a fairly complicated program to compare two arrays of numbers which was the basis for the code below. I tried to rename things a little more logically but there's still a good bit of alphabet soup. Give it a try and let me know if it works and if it makes sense to you.

Sub SingleArrayPermutations()
'Reads in an array and outputs the combinations that fall within a particular value range
Dim inputRng As Range, outputRng As Range, oCell As Range
Dim Count1 As Long, Counter As Long, i As Long, j As Long, k As Long, m As Long, n As Long
Dim readInCounter As Long: readInCounter = 0
Dim readInArray() As Double
Dim allCombinations() As Variant 'Holds all the possible combinations of readInArray
Set inputRng = Application.InputBox(Prompt:="Select the input numbers", Default:=ActiveCell, Type:=8)
Set outputRng = Application.InputBox(Prompt:="Select one cell where you want the display to start", Default:=ActiveCell, Type:=8)
Dim lowBound As Integer: lowBound = Application.InputBox(Prompt:="Enter the lower bound number for the output", Default:=26, Type:=1)
Dim upperBound As Integer: upperBound = Application.InputBox(Prompt:="Enter the upper bound number for the output", Default:=30, Type:=1)
Count1 = inputRng.Cells.Count
ReDim readInArray(1 To Count1) As Double
ReDim allCombinations(1 To 2 ^ Count1 - 1, 0 To 1) As Variant
For Each oCell In inputRng.Cells
      readInCounter = readInCounter + 1
      readInArray(readInCounter) = oCell.Value
Next oCell
m = 1
For i = 1 To Count1
      k = 0
      For j = 1 To i
          k = k + 2 ^ (j - 1)
      Next j
      For n = m To k
          If n = k Then
                allCombinations(n, 0) = readInArray(i)
                allCombinations(n, 1) = CStr(readInArray(i))
          Else
                allCombinations(n, 0) = allCombinations(n - m + 1, 0) + readInArray(i)
                allCombinations(n, 1) = allCombinations(n - m + 1, 1) & "," & CStr(readInArray(i))
          End If
      Next n
      m = k + 1
Next i
  
j = 0
For i = 1 To UBound(allCombinations, 1)
    If allCombinations(i, 0) >= lowBound And allCombinations(i, 0) <= upperBound Then
        outputRng.Offset(j, 0) = allCombinations(i, 1)
        j = j + 1
    End If
Next i
  
veryEnd:
End Sub

Good luck

 

[SamyW]

Hi Craig,

Thank you so much for your reply..yes it is a complicated one

I tried running the code in excel, and it does gives back the result of permutations for summing up the numbers.

However is it possible to amend the code so that
1) once the number is used it should not be considered for the second combination. say if there are numbers 13,10,17,7,8,5 - so the 1st cobmination to return a value of 30 would be 13,17; then for the second combination it should not consider using number 13 and 17 again, instead return 10,7,8,5....i know its a bit complicated
2) the code returns the combinations for summing the numbers right from 26 upto 30.. is it possible to amend the code to a way so that the vba considers as - if the 1st number on the coloumn D - row A is 13, the excel picks up that number then looks down the coloumn to find a number for summing so that the result would be 30, if not then find a number to sum up with 13 to return the nearest value around 30 in desecding order (so i stated a range 26-30).
3) i also had a query, will the code work if i had numbers in decimal?

I really thank you again, i could not imagine myself doing this manually otherwise for 6500 rows and for 13 regions


Thanks again
Samy

 

[craig.penny]

Hello again,

There are a couple important points about the code below.
-It's probably way over complicated and I'm sure could be solved in a better way. If it occurs to me tonight I'll post back.
-It won't distinguish between (for example) 29.1 and 29.9 for what's the best way to order the numbers. Anything greater than 28 and less than or equal to 29 will all be treated as 29 for the purpose of determining the proper ordering. I hope that makes sense. On this point, I tried to order the sets and it bogged the code down. I tried using a bubble sort (way too slow) and sorting on a worksheet page. If someone had a better way to do this, perhaps it could be avoided altogether.
-It's still slow. If you have to do 100s or 1000s of rows, you might have to run this on smaller pieces of it and maybe walk away. I added a statusbar so you can see how it's going.
-Definitely run it on a couple of small sets (~10 or so numbers) to see if it's doing what you want.
-Good luck

Sub CombinationsWOReplacement()
Dim inputRng As Range, outputRng As Range, oCell As Range
Dim Count1 As Long, Counter As Long, i As Long, j As Long, k As Long, m As Long, n As Long, s As String
Dim readInCounter As Long: readInCounter = 0
Dim readInArray() As Variant
Dim allComs() As Variant
Dim flag As Boolean, flag2 As Boolean
Set inputRng = Application.InputBox(Prompt:="Select the input numbers", Default:=ActiveCell, Type:=8)
Set outputRng = Application.InputBox(Prompt:="Select one cell where you want the display to start", Default:=ActiveCell, Type:=8)
Dim lowBound As Integer: lowBound = Application.InputBox(Prompt:="Enter the lower bound number for the output", Default:=26, Type:=1)
Dim upperBound As Integer: upperBound = Application.InputBox(Prompt:="Enter the upper bound number for the output", Default:=30, Type:=1)
Application.ScreenUpdating = False
Application.EnableEvents = False
Count1 = inputRng.Cells.Count
ReDim readInArray(1 To Count1, 0 To 1) As Variant
ReDim allComs(1 To 2 ^ Count1 - 1, 0 To 1) As Variant
For Each oCell In inputRng.Cells
      readInCounter = readInCounter + 1
      readInArray(readInCounter, 0) = oCell.Value
      readInArray(readInCounter, 1) = "Available"
Next oCell
m = 1
For i = 1 To Count1
      k = 0
      For j = 1 To i
          k = k + 2 ^ (j - 1)
      Next j
      For n = m To k
          If n = k Then
                allComs(n, 0) = readInArray(i, 0)
                allComs(n, 1) = CStr(readInArray(i, 0))
          Else
                allComs(n, 0) = allComs(n - m + 1, 0) + readInArray(i, 0)
                allComs(n, 1) = allComs(n - m + 1, 1) & "," & CStr(readInArray(i, 0))
          End If
      Next n
      m = k + 1
Next i
m = 0
For n = upperBound To lowBound Step -1
    For i = 1 To UBound(allComs, 1)
        Application.StatusBar = Format((upperBound - n) / (upperBound - lowBound + 1) + i / UBound(allComs, 1) / (upperBound - lowBound + 1), "0.0%") & " Complete"
        If allComs(i, 0) >= n And allComs(i, 0) <= upperBound Then
            s = ""
            If i = 616 Then
                i = i
            End If
            flag2 = True
            For j = 1 To Len(allComs(i, 1))
                If Mid(allComs(i, 1), j, 1) = "," Or j = Len(allComs(i, 1)) Then
                    If j = Len(allComs(i, 1)) Then s = s & Mid(allComs(i, 1), j, 1)
                    flag = False
                    For k = 1 To UBound(readInArray, 1)
                        If readInArray(k, 0) = CDbl(s) And readInArray(k, 1) = "Available" Then
                            readInArray(k, 1) = "Maybe"
                            flag = True
                            Exit For
                        End If
                    Next k
                    s = ""
                    If Not flag Then flag2 = False
                Else
                    s = s & Mid(allComs(i, 1), j, 1)
                End If
            Next j
            If flag2 Then
                For k = 1 To UBound(readInArray, 1)
                    If readInArray(k, 1) = "Maybe" Then readInArray(k, 1) = "Used"
                Next k
                outputRng.Offset(m, 0) = allComs(i, 1)
                m = m + 1
            Else
                For k = 1 To UBound(readInArray, 1)
                    If readInArray(k, 1) = "Maybe" Then readInArray(k, 1) = "Available"
                Next k
            End If
        End If
    Next i
Next n
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

 

[craig.penny]

This is a bandaid instead of stitches but it's the best I can do right now. It's significantly faster than before but still not great.

Sub CombinationsWOReplacement()
Dim inputRng As Range, outputRng As Range, oCell As Range
Dim Count1 As Long, Counter As Long, i As Long, j As Long, k As Long, m As Long, n As Long, s As String
Dim readInCounter As Long: readInCounter = 0
Dim readInArray() As Variant
Dim allComs() As Variant
Dim subsetComs() As Variant
Dim flag As Boolean, flag2 As Boolean
Set inputRng = Application.InputBox(Prompt:="Select the input numbers", Default:=ActiveCell, Type:=8)
Set outputRng = Application.InputBox(Prompt:="Select one cell where you want the display to start", Default:=ActiveCell, Type:=8)
Dim lowBound As Integer: lowBound = Application.InputBox(Prompt:="Enter the lower bound number for the output", Default:=26, Type:=1)
Dim upperBound As Integer: upperBound = Application.InputBox(Prompt:="Enter the upper bound number for the output", Default:=30, Type:=1)
Application.ScreenUpdating = False
Application.EnableEvents = False
Count1 = inputRng.Cells.Count
ReDim readInArray(1 To Count1, 0 To 1) As Variant
ReDim allComs(1 To 2 ^ Count1 - 1, 0 To 1) As Variant
For Each oCell In inputRng.Cells
      readInCounter = readInCounter + 1
      readInArray(readInCounter, 0) = oCell.Value
      readInArray(readInCounter, 1) = "Available"
Next oCell
m = 1
For i = 1 To Count1
      k = 0
      For j = 1 To i
          k = k + 2 ^ (j - 1)
      Next j
      For n = m To k
          If n = k Then
                allComs(n, 0) = readInArray(i, 0)
                allComs(n, 1) = CStr(readInArray(i, 0))
          Else
                allComs(n, 0) = allComs(n - m + 1, 0) + readInArray(i, 0)
                allComs(n, 1) = allComs(n - m + 1, 1) & "," & CStr(readInArray(i, 0))
          End If
      Next n
      m = k + 1
Next i
m = 0
For i = 1 To UBound(allComs, 1)
    If allComs(i, 0) >= lowBound And allComs(i, 0) <= upperBound Then
        m = m + 1
        ReDim Preserve subsetComs(0 To 1, 1 To m) As Variant
        subsetComs(0, m) = allComs(i, 0)
        subsetComs(1, m) = allComs(i, 1)
    End If
Next i
m = 0
For n = upperBound To lowBound Step -1
    For i = 1 To UBound(subsetComs, 2)
        Application.StatusBar = Format((upperBound - n) / (upperBound - lowBound + 1) + i / UBound(subsetComs, 2) / (upperBound - lowBound + 1), "0.0%") & " Complete"
        s = ""
        flag2 = True
        For j = 1 To Len(subsetComs(1, i))
            If Mid(subsetComs(1, i), j, 1) = "," Or j = Len(subsetComs(1, i)) Then
                If j = Len(subsetComs(1, i)) Then s = s & Mid(subsetComs(1, i), j, 1)
                flag = False
                For k = 1 To UBound(readInArray, 1)
                    If readInArray(k, 0) = CDbl(s) And readInArray(k, 1) = "Available" Then
                        readInArray(k, 1) = "Maybe"
                        flag = True
                        Exit For
                    End If
                Next k
                s = ""
                If Not flag Then flag2 = False
            Else
                s = s & Mid(subsetComs(1, i), j, 1)
            End If
        Next j
        If flag2 Then
            For k = 1 To UBound(readInArray, 1)
                If readInArray(k, 1) = "Maybe" Then readInArray(k, 1) = "Used"
            Next k
            outputRng.Offset(m, 0) = subsetComs(1, i)
            m = m + 1
        Else
            For k = 1 To UBound(readInArray, 1)
                If readInArray(k, 1) = "Maybe" Then readInArray(k, 1) = "Available"
            Next k
        End If
    Next i
Next n
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

By the way, in my previous post the code included this gem:

            If i = 616 Then
                i = i
            End If

Just because I needed to set a breakpoint and forgot to remove it...

 

[SamyW]

Hello!

Thanks a ton for all the time you have been giving to this.

The code works magic on numbers upto 10 or 13. If i select an array of numbers more than that i am getting an error on the below line of the code

ReDim allComs(1 To 2 ^ Count1 - 1, 0 To 1) As Variant

The data on my actual sheet is at coloumn R.
I am really not good at VBA, can you advise what is the best way out?

Thanks

 

[craig.penny]

Hi SamW,

Yeah this reallys chews up memory with the 2^ thing. This is slightly better since it avoids the Variant data type but not by much.

Sub CombinationsWOReplacement()
Dim inputRng As Range, outputRng As Range, oCell As Range
Dim Count1 As Long, Counter As Long, i As Long, j As Long, k As Long, m As Long, n As Long, s As String
Dim readInCounter As Long: readInCounter = 0
Dim readInArray() As Variant
Dim sinAllComs() As Single
Dim strAllComs() As String
Dim subsetComs() As Variant
Dim flag As Boolean, flag2 As Boolean
Set inputRng = Application.InputBox(Prompt:="Select the input numbers", Default:=ActiveCell, Type:=8)
Set outputRng = Application.InputBox(Prompt:="Select one cell where you want the display to start", Default:=ActiveCell, Type:=8)
Dim lowBound As Integer: lowBound = Application.InputBox(Prompt:="Enter the lower bound number for the output", Default:=26, Type:=1)
Dim upperBound As Integer: upperBound = Application.InputBox(Prompt:="Enter the upper bound number for the output", Default:=30, Type:=1)
Application.ScreenUpdating = False
Application.EnableEvents = False
Count1 = inputRng.Cells.Count
ReDim readInArray(1 To Count1, 0 To 1) As Variant
ReDim sinAllComs(1 To 2 ^ Count1 - 1) As Single
ReDim strAllComs(1 To 2 ^ Count1 - 1) As String
For Each oCell In inputRng.Cells
      readInCounter = readInCounter + 1
      readInArray(readInCounter, 0) = oCell.Value
      readInArray(readInCounter, 1) = "Available"
Next oCell
m = 1
For i = 1 To Count1
        Application.StatusBar = "Part 1 of 2 " & Format(i / Count1, "0.0%") & " Complete"
      k = 0
      For j = 1 To i
          k = k + 2 ^ (j - 1)
      Next j
      For n = m To k
          If n = k Then
                sinAllComs(n) = readInArray(i, 0)
                strAllComs(n) = CStr(readInArray(i, 0))
          Else
                sinAllComs(n) = sinAllComs(n - m + 1) + readInArray(i, 0)
                strAllComs(n) = strAllComs(n - m + 1) & "," & CStr(readInArray(i, 0))
          End If
      Next n
      m = k + 1
Next i
m = 0
For i = 1 To UBound(sinAllComs, 1)
    If sinAllComs(i) >= lowBound And sinAllComs(i) <= upperBound Then
        m = m + 1
        ReDim Preserve subsetComs(0 To 1, 1 To m) As Variant
        subsetComs(0, m) = sinAllComs(i)
        subsetComs(1, m) = strAllComs(i)
    End If
Next i
m = 0
For n = upperBound To lowBound Step -1
    For i = 1 To UBound(subsetComs, 2)
        Application.StatusBar = "Part 2 of 2 " & _
            Format((upperBound - n) / (upperBound - lowBound + 1) + i / UBound(subsetComs, 2) / (upperBound - lowBound + 1), "0.0%") & " Complete"
        s = ""
        flag2 = True
        For j = 1 To Len(subsetComs(1, i))
            If Mid(subsetComs(1, i), j, 1) = "," Or j = Len(subsetComs(1, i)) Then
                If j = Len(subsetComs(1, i)) Then s = s & Mid(subsetComs(1, i), j, 1)
                flag = False
                For k = 1 To UBound(readInArray, 1)
                    If readInArray(k, 0) = CDbl(s) And readInArray(k, 1) = "Available" Then
                        readInArray(k, 1) = "Maybe"
                        flag = True
                        Exit For
                    End If
                Next k
                s = ""
                If Not flag Then flag2 = False
            Else
                s = s & Mid(subsetComs(1, i), j, 1)
            End If
        Next j
        If flag2 Then
            For k = 1 To UBound(readInArray, 1)
                If readInArray(k, 1) = "Maybe" Then readInArray(k, 1) = "Used"
            Next k
            outputRng.Offset(m, 0) = subsetComs(1, i)
            m = m + 1
        Else
            For k = 1 To UBound(readInArray, 1)
                If readInArray(k, 1) = "Maybe" Then readInArray(k, 1) = "Available"
            Next k
        End If
    Next i
Next n
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.StatusBar = ""
End Sub

 

[shg]

Why not just pack the books 30 to a box and be done with it?

 

[SamyW]

Hi Craig,

thanks again for replying back.

Your code has been doing wonders and helping me sorting the smaller group of numbers.

However, when i try to run the code on subset of 28 numbers (thats the total kinds of books i have) it gets stuck at the same place as i earlier stated.

Thanks

 

[HarryS]

'
' to pick the groups of items that total
'
Private Sub CommandButton1_Click()
    DoGetTotals [A1], [B1], [B3] ' number to do , start item,  total needed
End Sub


Sub DoGetTotals(NumDo&, StartAt&, NeedTot!)
    Dim Di&, XX&, XM&, CC&, II&, oo$, WTot!, Rot&
    Dim RaFrom As Range, RaOut As Range
    If NumDo < 20 Then ' set back to 14 and  % for speed.. 31 and & is slow
    [g1] = Timer
  Application.ScreenUpdating = False
  Set RaFrom = Range("a5:a19") ' items to pick from down column A
    Set RaOut = Range("d4")
    RaOut.CurrentRegion.ClearContents  ' out range
    '
' Look at all posible combinations from NumDo items 1 2,4,8,16,32..
'
    For Di = 0 To 2 ^ NumDo - 1
        CC = 0: II = StartAt - 1: WTot = 0
        XX = Di
        While XX > 0  ' break to binary
            XM = XX Mod 2
            II = II + 1
            If XM Then  ' bits are 1
                CC = CC + 1  ' count how many
                WTot = WTot + RaFrom(II, 1)  ' gather total
            End If
            XX = XX \ 2   ' divide down to eventual  0
        Wend
        '
        If WTot = NeedTot Then  ' list it out
        Rot = Rot + 2   ' row out
        RaOut(Rot, 1) = Di & " -> Rows "
      '
      ' redo maths for output
       CC = 1: II = StartAt - 1: WTot = 0
        XX = Di
        While XX > 0  ' break to binary
            XM = XX Mod 2
            II = II + 1
            If XM Then  ' bits are 1
                CC = CC + 1  ' count how many
               RaOut(Rot, CC) = RaFrom(II, 1).Row
               RaOut(Rot + 1, CC) = RaFrom(II, 1).Value
                WTot = WTot + RaFrom(II, 1)
            End If
            XX = XX \ 2
        Wend
       RaOut(Rot + 1, CC + 1) = "T= " & WTot
        End If
          Next Di
    
    RaOut.CurrentRegion.Columns.AutoFit
    [g2] = Timer - [g1]
    
    Else
    MsgBox " less than 15 for any speed please "
    End If
 Application.ScreenUpdating = True
 
End Sub

Sheet like

5	1	<tbody> </tbody>				25840
Num to do	Start Num					0.021		sec
Total to Match	206
From
34			6 -> Rows	6	7
86				86	120	T= 206
120			27 -> Rows	5	6	8	9
-48				34	86	-48	134	T= 206
134			28 -> Rows	7	8	9
-3				120	-48	134	T= 206
120
-34
126

<tbody>
</tbody>