This code is driving me bonkers!

Martin Liss
Martin Liss used Ask the Experts™
on
I'm trying to scale up the code found here. To run it you put a 0 in column'B' for each row, and in C9 the SUMPRODUCT formula =SUMPRODUCT(A1:A12*B1:B12). When the ABC sub is run column 'D' should list all the combinations that add to a desired result, which I have hard-coded into the sub as 24. I believe the list should be
10,10,4
12,12
11,1,12
11,12,1
13,11
8, 16

but when I run the code 10,10,4 and 8,16 are missing. Maybe that's because they involve the last few rows, but if so I can't find the reason why. In my opinion I'm a pretty good VBA programmer and I understand how SUMPRODUCT works, but I've spent days on this and I can't get it to work properly and it's driving me bonkers!

So what I'm looking for here is a correction to the code and an explanation of how the binary matching that the code uses works. I'm using Excel 2010.
Bonkers.xlsm
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Chris RaisinRetired Senior Systems Analyst/Programmer

Commented:
I do not quite understand your established data on the worksheet.

I placed a heap of zero values in column B and the formula in C9.

Then I created the macro as showing on the linked webpage.

What data should I be putting into column A before I run the macro?
Martin LissOlder than dirt
Most Valuable Expert 2017
Distinguished Expert 2018

Author

Commented:
Did you download the Bonkers.xlsm workbook that I attached?
Chris RaisinRetired Senior Systems Analyst/Programmer

Commented:
No, I did not notice that. I will do that now.

Stand by......
Ensure you’re charging the right price for your IT

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden using our free interactive tool and use it to determine the right price for your IT services. Start calculating Now!

Commented:
Sounds like homework. Is it? Just curious.
Martin LissOlder than dirt
Most Valuable Expert 2017
Distinguished Expert 2018

Author

Commented:
Lol, I’m 50 years away from homework:)
Chris RaisinRetired Senior Systems Analyst/Programmer

Commented:
OK, I am examining it.......I think I have made some headway via the debugger.
Stay with me.....

(and yes, judging by your experience in programming and your ranking in EE, I guessed it was not homework LOL)

Commented:
Fair enough. Didn’t see the ranking until after I asked. Sorry.
Chris RaisinRetired Senior Systems Analyst/Programmer

Commented:
It has something to do with the setting of the limits in "S".
I increased the value set to wf.Dec2Bin(i, 10) and that allows one extra number to come into the calculations (4)

My guess now is that we have to increase the value if "i" in that declaration by extending the range of the "for next loop
'For i = 0 To 511 '

Please stand by (I might be completely on wrong track).......

working...working.....think...think.....

Chris
Chris RaisinRetired Senior Systems Analyst/Programmer

Commented:
Well, it seems we have limitations when using the function Dec2Bin.

It cannot handle very large numbers (unless your processor is of extraordinarily powerful).

So I am writing my own converter and will try to see if that helps.

I had noticed that the number "4" in the first column was included in the run
(a "1" appeared against it in column B) when I increased the upper limit in the "For i = 0 to 511"
Loop . However it kept falling over at a certain point since the number "i" became too large for the
Dec2Bin() function to handle.

Be right back with the amended code. (Fingers crossed)

Chris
Chris RaisinRetired Senior Systems Analyst/Programmer

Commented:
Almost got it! (still a bit of a way to go)

The amended code is attached.

I have changed a few things:
     1. Changed the type of the variable "i" to a "Double" (required when using my new function called MyDec2Int)
     2. Changed the upper limit of the "Loop" to 765 (something that Excel's internal Dec2Int() cannot handle, its max is 511)
     3. Added a "Contenders" variable, which simply allows you to increase/decrease the number of values in column "A" as you wish  
         without having to change the code.
     4. Added a "CountNonBlanks" function to ascertain how many numbers are up for inclusion in calculation (storing value in "Contenders")
     5. Added a "MyDec2Bin" to replace wf.Dec2Bin (the "buggy" worksheet function Dec2Bin)
     6. Added a "ZeroPadLeft" so that the function "MyDec2Bin" returns correctly formatted (leading zeros) value from MyDec2Bin
     7. Now using the value stored in the spreadsheet in cell "E1" tas the "total" you which to use when multiple numbers are added together (24 was hardcoded previously)
         The user can now decide on a different total without having to change the code.
 
The problem was inherent in the limitations placed on the Excel function Dec2Bin by the processor.
Obviously they have written that function to handle only a certain size numeric in binary format (no more than 9 digits in the binary number).
We needed a 12 digit number size.

The results I get back are as follows:

  Results received after running macro ABC stored in Excel Workbook "Bonkers2.xlsm
There are still problem with the values in Column "B", so I suspect the results in Column C are not "spot on" yet.

 I will look further into the code to see why the values in columns B and C are still not accurate and then get back to you, but in the meantime
there is some light at the end of the tunnel.
   
A handy reference I used in my calulations is:
Binary Calculator

My thanks to "MacroWriter" on the following StackOverflow page for his terrific function "cn" (convert number) which I fiddled with to come up with
MyDec2Bin (it was returning incorrectly formatted string so I had to come up with "PadZerosLeft" to rectify that.
Code page that led to the enhanced function MyDec2Bin (based on the code "cn()" by MacroWriter

The code in Bonkers2.xlsm is currently as follows:

Option Explicit

Sub ABC()
    Dim i As Double, s As String
    Dim j As Long, K As Long
    Dim answer As String

    K = 1
    
    'some new lines added to ascertain how many numbers we are considering in column A
    Dim NB As Range
    Set NB = Application.Range("A1:A100")
    Dim Contenders As Integer
    Contenders = CountNonBlanks(NB)
    Dim nLimit As Long
    
    nLimit = (3 * 255) '765

    For i = 0 To nLimit
        'The length of the returned string to be stored in s is set at 12.
        ' Although the size of a binary to hold the value 765 is 11, lets make it 12 just to be safe!
        s = MyDec2Bin(i, 2, 12) 'call internal function to obtain extended Binary number (up to 12 digits, with a maximium of 35!)
        For j = 1 To Contenders
            Cells(j, 2).Value = Val(Mid(s, j, 1))
        Next j
        
        If Range("C13").Value = Range("E1").Value Then  'Cell E1 contains the desired total at which we wish to arrive
            answer = ""
            For j = 1 To Contenders
                If Cells(j, 2) = 1 Then answer = answer & "," & Cells(j, 1)
            Next j
            Cells(K, 4) = Mid(answer, 2)
            K = K + 1
        End If
    Next i
End Sub

Private Function CountNonBlanks(WorkRng As Range) As Integer
Dim total As Integer
Dim rng As Range
For Each rng In WorkRng
    If Not IsEmpty(rng.Value) Then
        total = total + 1
    End If
Next
CountNonBlanks = total
End Function

Private Function MyDec2Bin(ByVal n As Double, ByVal Base As Double, ByVal nLen As Integer) As String
  'n the number to convert
  'Base is the numberic system to which "n" is to be converted.
  'This function can convert to binary all the way to the length of the
  'digits string showing in the code below (maximum of 36!)

  Dim x As Double  'The exponent without decimals
  Dim xx As Double 'The exponent with decimals, if any
  Dim r As String  'The return string
  Dim p As Integer 'Posistion of the digit in the return string
  Dim L As Long    'Length of the string return string
  Dim d            '(d+1) because mid() does not accept 0.
                    'The position of the digit in the digits string.
  Dim v As Double   'The numeric value of the position
                    'of the digit in the return string
  Dim digits As String
  digits = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
Start:
  If n > 0 Then
     xx = Log(n) / Log(Base)
     x = Int(xx)
  End If
  p = x + 1
  If r = "" Then
    r = String(p, "0")
    L = p
  End If
  v = Base ^ x
  d = n \ v
  Mid(r, L - x, 1) = Mid(digits, d + 1, 1)
  n = n - (v * d)
  If n <> 0 Then GoTo Start
  MyDec2Bin = ZeroPadLeft(r, nLen)
End Function

Private Function ZeroPadLeft(StrIn As String, nLen As Integer) As String
    Dim nZeros As Long
    Dim strOut As String
    nZeros = (nLen - Len(StrIn))
    If nZeros < 0 Then nZeros = 0
    ZeroPadLeft = String(nZeros, "0") & StrIn
End Function

Open in new window

Results2.jpg
Bonkers2.xlsm
Chris RaisinRetired Senior Systems Analyst/Programmer

Commented:
Howdy Martin.....

I notice you claim the follow two combinations should be showing:

11,1,12
11,12,1

If that is so, surely "1,12,11",  "1,11,12",  "12,11,1"  and "12,1,11" should also be showing.

Do you want it so that the combinations are distinct?  (I think double-ups are caused by the numbers being used more than once in Column A)

I COULD get the code to ignore duplicate combinations, as distinct from permutations.....or it the other way around? (LOL....The Uni days go back about 55 years!)

Further comparisons of my results so far show that I am missing the two values "11,1,12" and "11,12,1" showing in your listing
and YOU are missing the two values "12,4,8" and "12,4,8" (identical) showing in my listing.

I will have to go off to bed now, since I have to get up for my Bridge game starting at 10.00am (and it takes an hour to drive there) so I have to get up
after at least 8 hours sleep. It is 12:16am and I think I have put in about .12 hours work on this (better get something to eat before I hit the sack).

I will continue on tomorrow afternoon when I get home from Bridge.

In the meantime, please clarify my query re repeating "combinations" (i.e. same numbers but in different order) and why the values "12,4,8" were not
included in your list of proposed valid results.

Cheers
Chris
Martin LissOlder than dirt
Most Valuable Expert 2017
Distinguished Expert 2018

Author

Commented:
I said that both 11,1,12 and 11,12,1 should be there but that was incorrect. As long as the total of the numbers add to 24 I don't care how many there are (there are 6 possible). At least one combination of 12, 4 and 8 should also be in the list.
Chris RaisinRetired Senior Systems Analyst/Programmer

Commented:
OK (I'm, still up!) :-)

It was just that those values 12,4 and 8 were not in your original list.

I will put a process in place to not list a combination if it (or one of its its permutation's is already listed).

I will resume work on this in about 12 hours when I get back home. (I am finding this really stimulating, actually).

Night..night..

Chris
Older than dirt
Most Valuable Expert 2017
Distinguished Expert 2018
Commented:
Thanks for your help. I decided to document the code, and doing that caused me to realize what I was doing wrong.
Martin LissOlder than dirt
Most Valuable Expert 2017
Distinguished Expert 2018

Author

Commented:
BTW Chris, if you object to the way I closed this question then please object, and I won't have a problem with you getting the points.
Martin LissOlder than dirt
Most Valuable Expert 2017
Distinguished Expert 2018

Author

Commented:
Here's a documented solution for 11 rows of data where a total = 24 is looked for. I would definitely change the variable names to make them more meaningful.

Sub ScaleUp()
    Dim i As Long, s As String
    Dim j As Long, K As Long
    Dim answer As String

    ' The purpose of this code is to find all the combinations of numbers in
    ' column 'A' that add to a target value or range of values.
    '
    ' Understanding the "For i To" loop is the key to understading the process
    ' and for the purposes of this explanation I'll refer to it as "For i = 1 To N".
    ' The loop implements a "brute force" method which loops from 1 (one) to N,
    ' first creating a string of 0's and 1's equal to the binary value of N and
    ' then putting each character of the string, one by one, top to bottom in the
    ' cells of column 'B'. A SUMPRODUCT formula is then used to get the result of
    ' multipling the values in column 'A' by the adjacent zero or one in column 'B'.
    ' If that total matches the target value or range of values it puts the
    ' column 'A' values of the successful calculation in a cell in column 'D'.
    '
    ' In order to potentially be able to put a one in every cell in 'B", the
    ' string's length needs to be equal to the number or rows of data. That can
    ' happen only if N is the largest number with a binary value of all ones. For
    ' 8 rows N would need to be 255, for 9 N it would need to be 511, for 10 1023
    ' and for 11 2047, etc. Note that with 8 rows and an N of 255 the code would
    ' loop 8 * 255 or 2040 times, with 9 rows it would be 9 x 511 or 4599 times
    ' and since 10 x 1023 is 10230 and 11 x 2047 is 22517 it quickly becomes
    ' impractical to use the process with additional rows. Also Excel's built
    ' in DECTOBIN has an upper limit of 511 you would need to implment a VBA
    ' version of it to do this with more than 9 rows of data.
 
    K = 1

    For i = 0 To 2047
        s = DecToBin(i, 11) ' This is NOT Excel's DECTOBIN
        For j = 1 To 11
            Cells(j, 2).Value = Val(Mid(s, j, 1))
        Next j
        If Range("C12").Value = 24 Then ' This could be a range or multiple values
            answer = ""
            ' This loop looks at the 8 values in column 'B' and if they
            ' are 1, then the corresponding values in column 'A' are concatenated.
            For j = 1 To 11 '8
                If Cells(j, 2) = 1 Then answer = answer & "," & Cells(j, 1)
            Next j
            Cells(K, 4) = Mid(answer, 2)
            K = K + 1
        End If
    Next i
End Sub

Open in new window

Function DecToBin(ByVal DecimalIn As Variant, Optional NumberOfBits As Variant) As String
  DecToBin = ""
  DecimalIn = CDec(DecimalIn)
  Do While DecimalIn <> 0
    DecToBin = Trim$(Str$(DecimalIn - 2 * Int(DecimalIn / 2))) & DecToBin
    DecimalIn = Int(DecimalIn / 2)
  Loop
  If Not IsMissing(NumberOfBits) Then
    If Len(DecToBin) > NumberOfBits Then
      DecToBin = "Error - Number too large for bit size"
    Else
      DecToBin = Right$(String$(NumberOfBits, "0") & _
      DecToBin, NumberOfBits)
    End If
  End If
End Function

Open in new window

Chris RaisinRetired Senior Systems Analyst/Programmer

Commented:
I am a little disappointed (for me) being the first time I have started back into this process after 12 months illness, still, I am happy (for you) to have arrived at a solution. :-)

I was actually thinking of an even simpler method (while I slept)! and was keen to have a go at replacing all this with a simple function involving array manipulation.

I notice though that you have awarded me 500 points, and then also noted that you have offered me a chance for objection.

Under this system (all very new to me after being away for so long) how do I lodge an objection and would I earn any more points by doing so anyway.? Is 500 about all I will get if an objection is upheld? Points are not the main thing of course, just a happy outcome for all concerned.
Please advise the situation re objection.

If it is alright with you, I would like to simplify all this procedure and replace all this code with an alternative call to a new function which
could then work, (with or without a spreadsheet) . If so, I will post that function under this question as a follow-up.

I just also noticed a bit of "jimmying" in your own written function Dec2Bin where you actually opt out with an
"Error - Number too large for bit size".  
My code bypassed that problem, since it allowed any size number, so I am a bit surprised you allow this restriction back in.

Anyway, it still is a challenge, and I will ponder on it until I find a solution I am totally happy with (just for the record).
Hopefully you will allow me to then post it to this message.

Cheers
Chris
Martin LissOlder than dirt
Most Valuable Expert 2017
Distinguished Expert 2018

Author

Commented:
I answer a lot of questions but I haven't asked more than 10 in the 20 years I've been a member, and this is the first one since the new method of awarding points was implemented, so I don't know for sure but I think if you object you will get to keep the 500 points which I added for you being helpful, and you would get an additional 3000 points if I accepted one of your posts as the solution.

I found that Dec2Bin function on the web and it seemed to work so it was good enough for me.

If you do develop a scalable solution that would handle, say, two hundred rows of data, I'd be very happy to see it. (No sarcasm intended)
Chris RaisinRetired Senior Systems Analyst/Programmer

Commented:
OK thanks, I'll work on it! :-)

I am unable to work out the mechanism for objecting, so I guess I will just have to live with just getting 500 points. I will see if I can improve on the results sofar and post them here if I do.

Cheers
Chris

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial