VBA code: Just a little modification

Arnolf

Board Regular
Joined
Sep 18, 2005
Messages
78
Hello,
I have the below next Sixth Sense's code, that I found in:
http://www.mrexcel.com/board2/viewtopic.php?t=80690


The code displays the results:
cformat.xls
ABCDEF
1listDesired sumpossible combinationSum
21104+6=10
322+3+5=10
431+4+5=10
541+3+6=10
651+2+3+4=10
76
8
9
10
11
12
13
14
15
Sheet1




Code:
Option Explicit
Dim n, k, q As Double
Dim Comblist() As String
Dim b()
Dim Ans() As Variant
Private Sub Comb(j, m As Integer)
Dim tmp, X
    If j > n Then
        tmp = ""
        For X = 1 To n
            tmp = tmp & b(X)
        Next X
        
        q = q + 1
        ReDim Preserve Comblist(UBound(Comblist) + 1) As String
        Comblist(UBound(Comblist)) = tmp

    Else
        If k - m< n - j + 1 Then
            b(j) = 0
            Comb j + 1, m
        End If
        If m< k Then
            b(j) = 1
            Comb j + 1, m + 1
        End If
    End If
End Sub

Sub Sumxxx()
Dim St, i, j, tmp, Tmp2, AnsCount, L, Res
Dim listx()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
n = Range("a65536").End(xlUp).Row - 1
Res = Range("b2").Value
q = 0
ReDim Comblist(0) As String
ReDim b(n)
ReDim listx(n)
ReDim Ans(0)
For k = 1 To n
Comb 1, 0
Next k
For i = 1 To n
    listx(i) = Range("a" & 1 + i).Value
Next i
AnsCount = 0
For i = LBound(Comblist) To UBound(Comblist)
    St = ""
    tmp = 0
    For j = 1 To Len(Comblist(i))
        tmp = tmp + Mid(Comblist(i), j, 1) * listx(j)
        If Mid(Comblist(i), j, 1) = 1 Then
            St = St & "+" & listx(j)
        End If
    Next j
    If tmp = Res Then 'Or (tmp >= 0.9 * Res And tmp<= 1.1 * Res) Then
        ReDim Preserve Ans(UBound(Ans) + 1)
        AnsCount = AnsCount + 1
        Ans(AnsCount) = St
    End If
Next i
Range("e2:f65536").Value = ""
For i = LBound(Ans) + 1 To UBound(Ans)
    Range("e" & i + 1).Value = "'" & Mid(Ans(i), 2, Len(Ans(i))) & "="
    Range("F" & i + 1).Value = "=" & Ans(i)
Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub
 

Some videos you may like

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.

Arnolf

Board Regular
Joined
Sep 18, 2005
Messages
78
But, I need modificate the code in order displays the results in the next way:

How can modificate that ?.

Your help is much appreciated
rgds,
Arnolf.


I need this:
combin.xls
ABCDEFGHIJ
1listDesired sumSumpossible combination
21101046
3210235
4310145
5410136
65101234
76
8
9
10
11
12
13
14
15
Sheet 1



EDIT: There was an error in my screenshot (cell A8)
 

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
76,061
Office Version
  1. 365
Platform
  1. Windows
This seems to work.
Code:
Dim n, k, q As Double
Dim Comblist() As String
Dim b()
Dim Ans() As Variant
Private Sub Comb(j, m As Integer)
Dim tmp, X
    If j > n Then
        tmp = ""
        For X = 1 To n
            tmp = tmp & b(X)
        Next X
        
        q = q + 1
        ReDim Preserve Comblist(UBound(Comblist) + 1) As String
        Comblist(UBound(Comblist)) = tmp

    Else
        If k - m < n - j + 1 Then
            b(j) = 0
            Comb j + 1, m
        End If
        If m < k Then
            b(j) = 1
            Comb j + 1, m + 1
        End If
    End If
End Sub

Sub Sumxxx()
Dim St, i, j, tmp, Tmp2, AnsCount, L, Res
Dim listx()
Dim nums

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
n = Range("a65536").End(xlUp).Row - 1
Res = Range("b2").Value
q = 0
ReDim Comblist(0) As String
ReDim b(n)
ReDim listx(n)
ReDim Ans(0)
For k = 1 To n
Comb 1, 0
Next k
For i = 1 To n
    listx(i) = Range("a" & 1 + i).Value
Next i
AnsCount = 0
For i = LBound(Comblist) To UBound(Comblist)
    St = ""
    tmp = 0
    For j = 1 To Len(Comblist(i))
        tmp = tmp + Mid(Comblist(i), j, 1) * listx(j)
        If Mid(Comblist(i), j, 1) = 1 Then
            St = St & "+" & listx(j)
        End If
    Next j
    If tmp = Res Then 'Or (tmp >= 0.9 * Res And tmp <= 1.1 * Res) Then
        ReDim Preserve Ans(UBound(Ans) + 1)
        AnsCount = AnsCount + 1
        Ans(AnsCount) = St
    End If
Next i

Range("e2:Z65536").ClearContents

For i = LBound(Ans) + 1 To UBound(Ans)
    Range("e" & i + 1).Value = "=" & Ans(i)
    
    nums = Split(Ans(i), "+")
    For k = 1 To UBound(nums)
        Range("E" & i + 1).Offset(0, k) = nums(k)
    Next k
    
Next i

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,118,826
Messages
5,574,530
Members
412,601
Latest member
TheBeaniacExpress
Top