What could be slowing down my Excel VBA Macro?

This fun开发者_运维问答ction 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 (CStr(D2B(x))) twice.
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.

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!