Add & calculate Values in Scripting.Dictionary

Dear Mike,
Sorry for delyed reply but you are simply great...

With the help of your codes the results are coming in very less time.

I have further reduced the entries in array by restricting via IF condition.
Just one more help is required. When I run the program for below mentioned sizes the I am getting error - "Out of memory (Error 7)" might be due to the combinations are coming to some 1,331,000 no.s which array is not able to handle.

I have tried to define array as Long or Double not get success.

Main Size Size1 Size2 Size3 Size4 Size5 Size6 Size7
1020 100 101 102 103 104 105 106

Please suggest if there is any solution.

Sub MinCombo()
Dim i1, i2, i3, i4, i5, i6, i7, j, k, x, y, z, tt As Long
Dim arr(), Fix_Value, Main_Size, A_Cal

Main_Size = Range("A2").Value
Fix_Value = Range("J1").Value
A_Cal = Range("L1").Value

If (Range("B2") > 0) Then i1 = Application.WorksheetFunction.RoundDown(Range("A2") / Range("B2"), 0)
If (Range("C2") > 0) Then i2 = Application.WorksheetFunction.RoundDown(Range("A2") / Range("C2"), 0)
If (Range("D2") > 0) Then i3 = Application.WorksheetFunction.RoundDown(Range("A2") / Range("D2"), 0)
If (Range("E2") > 0) Then i4 = Application.WorksheetFunction.RoundDown(Range("A2") / Range("E2"), 0)
If (Range("F2") > 0) Then i5 = Application.WorksheetFunction.RoundDown(Range("A2") / Range("F2"), 0)
If (Range("G2") > 0) Then i6 = Application.WorksheetFunction.RoundDown(Range("A2") / Range("G2"), 0)
If (Range("H2") > 0) Then i7 = Application.WorksheetFunction.RoundDown(Range("A2") / Range("H2"), 0)

tt = (i1 + 1) * (i2 + 1) * (i3 + 1) * (i4 + 1) * (i5 + 1) * (i6 + 1) * (i7 + 1)

response = MsgBox("No. of combinations are => " & tt, vbOK)
If response = vbCancel Then
    MsgBox ("Macro Ending")
    Exit Sub
End If

Range("A3:Z65536").Select
    Selection.ClearContents
Range("B2").Select
ii = 0
ReDim arr(1 To tt, 1 To 16)
For x1 = 0 To i1
    For x2 = 0 To i2
        For x3 = 0 To i3
            For x4 = 0 To i4
                For x5 = 0 To i5
                    For x6 = 0 To i6
                        For x7 = 0 To i7
                            ii = Main_Size - Cells(2, "b") * x1 - Cells(2, "c") * x2 - Cells(2, "d") * x3 - Cells(2, "e") * x4 - Cells(2, "f") * x5 - Cells(2, "g") * x6 - Cells(2, "h") * x7
                            If ii >= 0 And ii <= A_Cal Then
                            i = i + 1
                            arr(i, 1) = x1
                            arr(i, 2) = x2
                            arr(i, 3) = x3
                            arr(i, 4) = x4
                            arr(i, 5) = x5
                            arr(i, 6) = x6
                            arr(i, 7) = x7
                            arr(i, 8) = Main_Size - Cells(2, "b") * x1 - Cells(2, "c") * x2 - Cells(2, "d") * x3 - Cells(2, "e") * x4 - Cells(2, "f") * x5 - Cells(2, "g") * x6 - Cells(2, "h") * x7
                            arr(i, 9) = Round(x1 * Cells(2, "b") * Cells(1, "j") / Cells(2, "a"), 2)
                            arr(i, 10) = Round(x2 * Cells(2, "c") * Cells(1, "j") / Cells(2, "a"), 2)
                            arr(i, 11) = Round(x3 * Cells(2, "d") * Cells(1, "j") / Cells(2, "a"), 2)
                            arr(i, 12) = Round(x4 * Cells(2, "e") * Cells(1, "j") / Cells(2, "a"), 2)
                            arr(i, 13) = Round(x5 * Cells(2, "f") * Cells(1, "j") / Cells(2, "a"), 2)
                            arr(i, 14) = Round(x6 * Cells(2, "g") * Cells(1, "j") / Cells(2, "a"), 2)
                            arr(i, 15) = Round(x7 * Cells(2, "h") * Cells(1, "j") / Cells(2, "a"), 2)
                            arr(i, 16) = Round(Fix_Value - WorksheetFunction.Sum(arr(i, 9), arr(i, 10), arr(i, 11), arr(i, 12), arr(i, 13), arr(i, 14), arr(i, 15)), 2)
                            End If
                        Next
                    Next
                Next
            Next
        Next
    Next
Next

response = MsgBox("No. of rows filled will be => " & i, vbOK)
If response = vbCancel Then
    MsgBox ("Macro Ending")
    Exit Sub
End If

    Range("b3:r" & i) = arr
'Range("b3").Resize(UBound(arr, 1), UBound(arr, 2)) = arr

End Sub

Hi -

The error is in the tt variable, I changed it to 65536 since it will not goes to that number I guess.
transfer some to variables so it will always access once.
It Took : 11.8906 seconds from my machine

Sub MinCombo()
Dim t As Single
t = Timer
Dim i1 As Long, i2 As Long, i3 As Long, i4 As Long, i5 As Long, i6 As Long, i7 As Long, j As Long
Dim k As Long, x As Long, y As Long, z As Long, tt As Long
Dim arr(), Fix_Value As Long, Main_Size As Long, A_Cal As Long
Dim mu As Double, b As Double, c As Double, d As Double, e As Double, f As Double, g As Double, h As Double
Dim bb As Double, cc As Double, dd As Double, ee As Double, ff As Double, gg As Double, hh As Double
Main_Size = Range("A2").Value
Fix_Value = Range("J1").Value
A_Cal = Range("L1").Value

If (Range("B2") > 0) Then i1 = Application.WorksheetFunction.RoundDown(Range("A2") / Range("B2"), 0)
If (Range("C2") > 0) Then i2 = Application.WorksheetFunction.RoundDown(Range("A2") / Range("C2"), 0)
If (Range("D2") > 0) Then i3 = Application.WorksheetFunction.RoundDown(Range("A2") / Range("D2"), 0)
If (Range("E2") > 0) Then i4 = Application.WorksheetFunction.RoundDown(Range("A2") / Range("E2"), 0)
If (Range("F2") > 0) Then i5 = Application.WorksheetFunction.RoundDown(Range("A2") / Range("F2"), 0)
If (Range("G2") > 0) Then i6 = Application.WorksheetFunction.RoundDown(Range("A2") / Range("G2"), 0)
If (Range("H2") > 0) Then i7 = Application.WorksheetFunction.RoundDown(Range("A2") / Range("H2"), 0)

tt = (i1 + 1) * (i2 + 1) * (i3 + 1) * (i4 + 1) * (i5 + 1) * (i6 + 1) * (i7 + 1)

response = MsgBox("No. of combinations are => " & tt, vbOK)
If response = vbCancel Then
    MsgBox ("Macro Ending")
    Exit Sub
End If

Range("A3:Z65536").Select
    Selection.ClearContents
Range("B2").Select
ii = 0
mu = Cells(2, "a")
b = Cells(2, "b") * Cells(1, "j")
c = Cells(2, "c") * Cells(1, "j")
d = Cells(2, "d") * Cells(1, "j")
e = Cells(2, "e") * Cells(1, "j")
f = Cells(2, "f") * Cells(1, "j")
g = Cells(2, "g") * Cells(1, "j")
h = Cells(2, "h") * Cells(1, "j")
bb = Cells(2, "b")
cc = Cells(2, "c")
dd = Cells(2, "d")
ee = Cells(2, "e")
ff = Cells(2, "f")
gg = Cells(2, "g")
hh = Cells(2, "h")
ReDim arr(1 To 65536, 1 To 16)
For x1 = 0 To i1
    For x2 = 0 To i2
        For x3 = 0 To i3
            For x4 = 0 To i4
                For x5 = 0 To i5
                    For x6 = 0 To i6
                        For x7 = 0 To i7
                            ii = Main_Size - (bb * x1) - (cc * x2) - (dd * x3) - (ee * x4) - (ff * x5) - (gg * x6) - (hh * x7)
                            If ii >= 0 And ii <= A_Cal Then
                            i = i + 1
                            arr(i, 1) = x1
                            arr(i, 2) = x2
                            arr(i, 3) = x3
                            arr(i, 4) = x4
                            arr(i, 5) = x5
                            arr(i, 6) = x6
                            arr(i, 7) = x7
                            arr(i, 8) = ii 'Main_Size - b * x1 - c * x2 - d * x3 - e * x4 - f * x5 - g * x6 - h * x7
                            arr(i, 9) = Round(x1 * b / mu, 2)
                            arr(i, 10) = Round(x2 * c / mu, 2)
                            arr(i, 11) = Round(x3 * d / mu, 2)
                            arr(i, 12) = Round(x4 * e / mu, 2)
                            arr(i, 13) = Round(x5 * f / mu, 2)
                            arr(i, 14) = Round(x6 * g / mu, 2)
                            arr(i, 15) = Round(x7 * h / mu, 2)
                            arr(i, 16) = Round(Fix_Value - WorksheetFunction.Sum(arr(i, 9), arr(i, 10), arr(i, 11), arr(i, 12), arr(i, 13), arr(i, 14), arr(i, 15)), 2)
                            End If
                        Next
                    Next
                Next
            Next
        Next
    Next
Next

response = MsgBox("No. of rows filled will be => " & i, vbOK)
If response = vbCancel Then
    MsgBox ("Macro Ending")
    Exit Sub
End If

    Range("b3:q" & i) = arr
MsgBox Format(Timer - t, "#.0000") & " seconds"
End Sub

Regards,
Event

Dear Mike & Event,

You guys are simply G R E A T....

My issue is resolved. Got some thing more than waht I wanted....

Thanks alot.