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
```

### Answer：

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
```

### Answer：

```
mask = Right(fill & CStr(D2B(x)), Len(fill & CStr(D2B(x))))
```

The above line of code does the same thing (`CStr(D2B(x))`

) twice.

Store the result of `CStr(D2B(x))`

in a variable & use that variable in the above line of code.

### Answer：

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.

Something like

```
ws.Range(ws.cells(1, 1), ws.cells(UBound(dstArr, 1) + 1, UBound(dstArr, 2) + 1)) = dstArr
```

The array-copy-trick greatly improves performance!

Tags: excelexcel, vba