Macro CRASHES when I enter more than 20 lines. Can anyone improve the coding? (Macro Purpose is to find all possible combinations of NET ZERO)

[steveyyz2112]

Im using 32-bit Excel 2013....Would 64 bit help me? Can anyone send me improved version to allow for HIGHER computing ability? ie 30-40 lines? thanks very much for any input!
-------------------------------------------------------------
-------------------------------------------------------------

Private Sub CommandButton2_Click()
   
    Dim inputSheet As Worksheet
    Dim resultSheet As Worksheet

    Set inputSheet = ActiveWorkbook.Worksheets("Sheet2")
    Set resultSheet = ActiveWorkbook.Worksheets("Sheet2")
   
    lRow = inputSheet.Cells(inputSheet.Rows.Count, "A").End(xlUp).Row
   
    Dim letter() As String
    Dim letterCount As Integer
    Dim rowNum As Long, i As Long
    Dim workStr As String
    Dim finalArray As Variant
    Dim printPlace As Range
    Dim nSum As Double
   
    Set printPlace = ActiveSheet.Range("b1")
    letterCount = lRow
   
    ReDim letter(1 To letterCount)
    For i = 1 To letterCount
        letter(i) = ""
    Next i
   
    'ReDim finalArray(1 To (2 ^ letterCount))
    rowNum = 1
    resultRow = 1
    resultColumn = 2
   
    Do
        nSum = 0
        For i = 1 To letterCount
            If letter(i) = "" Then
                letter(i) = inputSheet.Cells(i, 1).Value
                Exit For
            Else
                letter(i) = ""
            End If
        Next i
       
        workStr = ""
        nSum = 0
        For i = 1 To letterCount
            If letter(i) <> "" Then workStr = workStr & letter(i)
            If letter(i) <> "" Then nSum = nSum + CDbl(letter(i))
        Next i
       
        If Abs(nSum) < 0.001 Then
            resultRow = 8
            For i = 1 To letterCount
                If letter(i) <> "" Then
                    inputSheet.Cells(resultRow, resultColumn).Value = letter(i)
                    resultRow = resultRow + 1
                End If
            Next i
            inputSheet.Cells(resultRow, resultColumn).Value = 0
            resultColumn = resultColumn + 1
        End If
        'finalArray(rowNum) = workStr
        rowNum = rowNum + 1
    Loop Until workStr = ""
   
    'printPlace.Range(Cells(1, 1), Cells(2 ^ letterCount, 1)).Value = _
    '                  Application.Transpose(finalArray)
    MsgBox "Populated"
End Sub

Private Sub CommandButton1_Click()

    Dim inputSheet As Worksheet
    Dim resultSheet As Worksheet

    Set inputSheet = ActiveWorkbook.Worksheets("Sheet4")
    Set resultSheet = ActiveWorkbook.Worksheets("Sheet4")
   
    lRow = inputSheet.Cells(inputSheet.Rows.Count, "A").End(xlUp).Row
   
    Dim letter() As String
    Dim letterCount As Integer
    Dim rowNum As Long, i As Long
    Dim workStr As String
    Dim finalArray As Variant
    Dim totalSum As Variant
   
    Dim printPlace As Range
    Dim nSum As Double
   
    Set printPlace = ActiveSheet.Range("B1")
    letterCount = lRow
   
    ReDim letter(1 To letterCount)
    For i = 1 To letterCount
        letter(i) = ""
    Next i
   
    ReDim finalArray(1 To (2 ^ letterCount))
    ReDim totalSum(1 To (2 ^ letterCount))
   
    rowNum = 1
   
    Do
        For i = 1 To letterCount
            If letter(i) = "" Then
                letter(i) = inputSheet.Cells(i, 1).Value
                Exit For
            Else
                letter(i) = ""
            End If
        Next i
       
        workStr = ""
        nSum = 0
        For i = 1 To letterCount
            If letter(i) <> "" Then workStr = workStr & letter(i) & ","
            If letter(i) <> "" Then nSum = nSum + Format(CDbl(letter(i)), "0.00")
        Next i
       
        If Abs(nSum) < 0.001 Then
            finalArray(rowNum) = workStr
            totalSum(rowNum) = nSum
           
            rowNum = rowNum + 1
        End If
    Loop Until workStr = ""
   
    printPlace.Range(Cells(1, 1), Cells(2 ^ letterCount, 1)).Value = _
                      Application.Transpose(finalArray)
                     
    printPlace.Range(Cells(1, 2), Cells(2 ^ letterCount, 2)).Value = Application.Transpose(totalSum)
   
End Sub

 

[offthelip]

you are doing multiple access to the worksheet in double loop, this is always going to be very slow vba and it could be the cause of your crashing
It is very easy to modify your code to use variant arrays instead of accessing the worksheet. I have modified your code to show you how to do it.

 Sub CommandButton2()
  
    Dim inputSheet As Worksheet
    Dim resultSheet As Worksheet

    Set inputSheet = ActiveWorkbook.Worksheets("Sheet2")
    Set resultSheet = ActiveWorkbook.Worksheets("Sheet2")
  
    lRow = inputSheet.Cells(inputSheet.Rows.Count, "A").End(xlUp).Row
    indata = Range(Cells(1, 1), Cells(lRow + 8, lRow * 2))
    Dim letter() As String
    Dim letterCount As Integer
    Dim rowNum As Long, i As Long
    Dim workStr As String
    Dim finalArray As Variant
    Dim printPlace As Range
    Dim nSum As Double
  
    Set printPlace = ActiveSheet.Range("b1")
    letterCount = lRow
  
    ReDim letter(1 To letterCount)
    For i = 1 To letterCount
        letter(i) = ""
    Next i
  
    'ReDim finalArray(1 To (2 ^ letterCount))
    rowNum = 1
    resultRow = 1
    resultColumn = 2
  
    Do
        nSum = 0
        For i = 1 To letterCount
            If letter(i) = "" Then
                letter(i) = indata(i, 1)
                Exit For
            Else
                letter(i) = ""
            End If
        Next i
      
        workStr = ""
        nSum = 0
        For i = 1 To letterCount
            If letter(i) <> "" Then workStr = workStr & letter(i)
            If letter(i) <> "" Then nSum = nSum + CDbl(letter(i))
        Next i
      
        If Abs(nSum) < 0.001 Then
            resultRow = 8
            For i = 1 To letterCount
                If letter(i) <> "" Then
                    indata(resultRow, resultColumn) = letter(i)
                    resultRow = resultRow + 1
                End If
            Next i
            indata(resultRow, resultColumn) = 0
            resultColumn = resultColumn + 1
        End If
        'finalArray(rowNum) = workStr
        rowNum = rowNum + 1
    Loop Until workStr = ""
    Range(Cells(1, 1), Cells(lRow + 8, lRow * 2)) = indata
    'printPlace.Range(Cells(1, 1), Cells(2 ^ letterCount, 1)).Value = _
    '                  Application.Transpose(finalArray)
    MsgBox "Populated"
End Sub

the only possible issue is defining the array indata to be the correct size, I have made it so there are twice as many columns as you have rows, depending on your data this might not be sufficient.
This will speed up your code at the very least even if it doesn't solve your crashing problem.

 

[StephenCrump]

In addition to offthelip's comments, you're also doing a lot of unnecessary string manipulation, i.e. reading the data into a String variable, letter, and then converting back to Double to take the sum.

You may also want to check out Tushar Mehta's code here: Combination of numbers that sum or match a target value

I haven't used this before, but a quick test (including pushing the limits out by changing all Integer to Long) shows it is very quick, particularly if you sort the input in the way suggested.