This function goes through all integers and picks out binary values with only five ones and writes them to the spreadsheet.
To run this
For x = 1 To 134217728 would take 2.5 days!!!! Help!
How could I speed this up?
Function D2B(ByVal n As Long) As String n = Abs(n) D2B = "" Do While n > 0 If n = (n \ 2) * 2 Then D2B = "0" & D2B Else D2B = "1" & D2B n = n - 1 End If n = n / 2 Loop End Function Sub mixtures() Dim x As Long Dim y As Integer Dim fill As String Dim mask As String Dim RowOffset As Integer Dim t As Date t = Now fill = "" For x = 1 To 134217728 mask = Right(fill & CStr(D2B(x)), Len(fill & CStr(D2B(x)))) Debug.Print mask If x > 100000 Then Exit For If Len(mask) - Len(WorksheetFunction.Substitute(mask, "1", "")) = 5 Then _ RowOffset = RowOffset + 1 For y = 1 To Len(mask) If Len(mask) - Len(WorksheetFunction.Substitute(mask, "1", "")) = 5 Then _ Range("mix").Offset(RowOffset).Cells(y) = Mid(mask, y, 1) Next Next Debug.Print DateDiff("s", Now, t) End Sub
By first sight guess, I think the problem lies in the fact that you do that cell by cell, which causes many read and write accesses.
You should do it range by range, like
vArr = Range("A1:C1000").Value ' it is array now, do something here effeciently Range("A1:C1000").Value = vArr
You want find all 28bit numbers with 5 1s
There are 28*27*26*25*24/5/4/3/2=98280 such numbers
The following code took ~10 seconds on my PC:
lineno = 1 For b1 = 0 To 27 For b2 = b1 + 1 To 27 For b3 = b2 + 1 To 27 For b4 = b3 + 1 To 27 For b5 = b4 + 1 To 27 Cells(lineno, 1) = 2 ^ b1 + 2 ^ b2 + 2 ^ b3 + 2 ^ b4 + 2 ^ b5 lineno = lineno + 1 Next Next Next Next Next
mask = Right(fill & CStr(D2B(x)), Len(fill & CStr(D2B(x))))
The above line of code does the same thing (
Store the result of
CStr(D2B(x)) in a variable & use that variable in the above line of code.
I’ve got 2 suggestions:
- Get rid of the substitution command by counting the ones/zeroes in D2B and return an empty string if the count does not equal 5
- Write these pre-filtered bitstrings to an array first and copy the array directly to the cells when finished.
ws.Range(ws.cells(1, 1), ws.cells(UBound(dstArr, 1) + 1, UBound(dstArr, 2) + 1)) = dstArr
The array-copy-trick greatly improves performance!