Out of Memory Error 7
Nice memory hog!
your arrays are a little bit bigger than what you actually need.
?49^6 13.841.287.201 elements.. of 2 bytes(integer) each
More efficient code for combinations (NOT permutations).
Option Explicit
Sub ACombiTester()
Dim x, T!
T = Timer
x = CombinationIndexer(25, 12)
MsgBox UBound(x) & vbTab & Format$(Timer - T, "0.0\s\.")
End Sub
Sub CreateCombinations()
'keepITcool 2004/11/01
Dim rSrc As Range, rDst As Range, rITM As Range
Dim cItm As Collection, vItm()
Dim aIdx() As Byte, vRes()
Dim nItm&, nDim&, nCnt&
Dim r&, c&
Set rSrc = Application.InputBox("Select the Source data", Type:=8)
If rSrc Is Nothing Then
Beep
Exit Sub
End If
'Create a collection of unique items in range.
Set cItm = New Collection
On Error Resume Next
For Each rITM In rSrc.Cells
If rITM < vbNullString Then cItm.Add rITM.Value2, CStr(rITM.Value2)
Next
nItm = cItm.Count
ReDim vItm(1 To nItm)
For r = 1 To nItm
vItm(r) = cItm(r)
Next
On Error GoTo 0
Let nDim = Application.InputBox("Size of 'groups' ", Type:=1)
If nDim < 1 Or nDim nItm Then
Beep
Exit Sub
End If
'Get the number of combinations
nCnt = Application.Combin(nItm, nDim)
If nCnt Rows.Count Then
MsgBox nCnt & " combinations...Wont fit :( ", vbCritical
'Exit Sub
End If
'Create the index array
ReDim aIdx(0 To 2, 1 To nDim) As Byte
'Create the result array
ReDim vRes(1 To nCnt, 1 To nDim)
'min on first row, max on last row
For c = 1 To nDim
aIdx(0, c) = c
aIdx(2, c) = nItm - nDim + c
vRes(1, c) = vItm(aIdx(0, c))
vRes(nCnt, c) = vItm(aIdx(2, c))
Next
For r = 2 To nCnt - 1
aIdx(1, nDim) = aIdx(0, nDim) + 1
For c = 1 To nDim - 1
If aIdx(0, c + 1) = aIdx(2, c + 1) Then
aIdx(1, c) = aIdx(0, c) + 1
Else
aIdx(1, c) = aIdx(0, c)
End If
Next
For c = 2 To nDim
If aIdx(1, c) aIdx(2, c) Then
aIdx(1, c) = aIdx(1, c - 1) + 1
End If
Next
For c = 1 To nDim
aIdx(0, c) = aIdx(1, c)
vRes(r, c) = vItm(aIdx(1, c))
Next
Next
dump:
Set rDst = Application.InputBox("Select the Destination Range",
Type:=8)
If rDst Is Nothing Then
Beep
Exit Sub
End If
If Rows.Count - rDst.Row < nCnt Then
Stop
ElseIf Columns.Count - rDst.Column < nDim Then
Stop
End If
With rDst
.CurrentRegion.Clear
.Resize(nCnt, nDim) = vRes
End With
End Sub
Function CombinationIndexer(ByVal nItm As Byte, _
ByVal nDim As Byte) As Byte()
Dim aIdx() As Byte, nCnt&, r&, c&
'Create the index array
On Error GoTo errH:
nCnt = Excel.WorksheetFunction.Combin(nItm, nDim)
ReDim aIdx(1 To nCnt, 1 To nDim)
'min on first row, max on last row
For c = 1 To nDim
aIdx(1, c) = c
aIdx(nCnt, c) = nItm - nDim + c
Next
For r = 2 To nCnt - 1
aIdx(r, nDim) = aIdx(r - 1, nDim) + 1
For c = 1 To nDim - 1
If aIdx(r - 1, c + 1) = aIdx(nCnt, c + 1) Then
aIdx(r, c) = aIdx(r - 1, c) + 1
Else
aIdx(r, c) = aIdx(r - 1, c)
End If
Next
For c = 2 To nDim
If aIdx(r, c) aIdx(nCnt, c) Then
aIdx(r, c) = aIdx(r, c - 1) + 1
End If
Next
Next
CombinationIndexer = aIdx
Exit Function
errH:
Select Case Err
Case 6, 7 'Out of memory/Overflow
MsgBox "This machine isn't equipped to deal with " & _
Format$(Excel.WorksheetFunction.Combin(nItm, nDim), "0.0e-0") &
_
" combinations." & _
vbNewLine & "A 'reasonable' maximum = " & "25/12 = " & _
Format$(Excel.WorksheetFunction.Combin(25, 12), "0.0e-0") & _
" combinations.", vbCritical, _
"CombinationIndexer"
Case Else
MsgBox Err.Description & vbTab & "(" & Err.Number & ")", _
vbCritical, "CombinationIndexer"
End Select
ReDim CombinationIndexer(0, 0)
End Function
--
keepITcool
| www.XLsupport.com | keepITcool chello nl | amsterdam
Paul Black wrote :
Hi Everyone,
I have Two Sheets, One Named No Bonus & the Other Named Bonus.
In Sheet No Bonus, I have Titles in Cells A1:G1. In Column A is the
Draw Number, and Columns B:G are the 6 Drawn Numbers ( Excluding the
Bonus Number ).
In Sheet Bonus, I have Titles in Cells A1:H1. In Column A is the Draw
Number, and Columns B:H are the 7 ( Including Bonus Number ) Drawn
Numbers in Ascending Order.
The Results go into Sheet Results.
I am Trying to List the Number of Times ALL Combinations of 5 Numbers
( Including & Excluding the Bonus Number ) from 49 ( Combin(49,5) =
1,906,884 ) have Occurred in the Lotto Draws to Date.
The Code Below for Some Reason gives Error 7 Out of Memory.
Any Help would be Appreciated.
Thanks in Advance.
Here is the Code :-
Option Explicit
Option Base 1
Sub List()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
Dim m As Integer
Dim nMinA As Integer
Dim nMaxF As Integer
Dim nCount As Long
Dim nDraw As Integer
Dim nNo(7) As Integer
Dim nBonus(49, 49, 49, 49, 49) As Integer
Dim nNoBonus(49, 49, 49, 49, 49) As Integer
Application.ScreenUpdating = False
nMinA = 1
nMaxF = 49
Sheets("No Bonus").Select
Range("A2").Select
Do While ActiveCell.Value 0
nDraw = ActiveCell.Value
ActiveCell.Offset(1, 0).Select
Loop
Range("A1").Select
For i = 1 To nDraw
For j = 1 To 7
nNo(j) = ActiveCell.Offset(i, j).Value
Next j
nNoBonus(nNo(1), nNo(2), nNo(3), nNo(4), nNo(5)) = _
nNoBonus(nNo(1), nNo(2), nNo(3), nNo(4), nNo(5)) + 1
nNoBonus(nNo(1), nNo(2), nNo(3), nNo(4), nNo(6)) = _
nNoBonus(nNo(1), nNo(2), nNo(3), nNo(4), nNo(6)) + 1
nNoBonus(nNo(1), nNo(2), nNo(3), nNo(5), nNo(6)) = _
nNoBonus(nNo(1), nNo(2), nNo(3), nNo(5), nNo(6)) + 1
nNoBonus(nNo(1), nNo(2), nNo(4), nNo(5), nNo(6)) = _
nNoBonus(nNo(1), nNo(2), nNo(4), nNo(5), nNo(6)) + 1
nNoBonus(nNo(1), nNo(3), nNo(4), nNo(5), nNo(6)) = _
nNoBonus(nNo(1), nNo(3), nNo(4), nNo(5), nNo(6)) + 1
nNoBonus(nNo(2), nNo(3), nNo(4), nNo(5), nNo(6)) = _
nNoBonus(nNo(2), nNo(3), nNo(4), nNo(5), nNo(6)) + 1
Next i
Sheets("Bonus").Select
Range("A2").Select
Do While ActiveCell.Value " "
nDraw = ActiveCell.Value
ActiveCell.Offset(1, 0).Select
Loop
Range("A1").Select
For i = 1 To nDraw
For j = 1 To 7
nNo(j) = ActiveCell.Offset(i, j).Value
Next j
nNoBonus(nNo(1), nNo(2), nNo(3), nNo(4), nNo(5)) = _
nNoBonus(nNo(1), nNo(2), nNo(3), nNo(4), nNo(5)) + 1
nNoBonus(nNo(1), nNo(2), nNo(3), nNo(4), nNo(6)) = _
nNoBonus(nNo(1), nNo(2), nNo(3), nNo(4), nNo(6)) + 1
nNoBonus(nNo(1), nNo(2), nNo(3), nNo(4), nNo(7)) = _
nNoBonus(nNo(1), nNo(2), nNo(3), nNo(4), nNo(7)) + 1
nNoBonus(nNo(1), nNo(2), nNo(3), nNo(5), nNo(6)) = _
nNoBonus(nNo(1), nNo(2), nNo(3), nNo(5), nNo(6)) + 1
nNoBonus(nNo(1), nNo(2), nNo(3), nNo(5), nNo(7)) = _
nNoBonus(nNo(1), nNo(2), nNo(3), nNo(5), nNo(7)) + 1
nNoBonus(nNo(1), nNo(2), nNo(3), nNo(6), nNo(7)) = _
nNoBonus(nNo(1), nNo(2), nNo(3), nNo(6), nNo(7)) + 1
nNoBonus(nNo(1), nNo(2), nNo(4), nNo(5), nNo(6)) = _
nNoBonus(nNo(1), nNo(2), nNo(4), nNo(5), nNo(6)) + 1
nNoBonus(nNo(1), nNo(2), nNo(4), nNo(5), nNo(7)) = _
nNoBonus(nNo(1), nNo(2), nNo(4), nNo(5), nNo(7)) + 1
nNoBonus(nNo(1), nNo(2), nNo(4), nNo(6), nNo(7)) = _
nNoBonus(nNo(1), nNo(2), nNo(4), nNo(6), nNo(7)) + 1
nNoBonus(nNo(1), nNo(2), nNo(5), nNo(6), nNo(7)) = _
nNoBonus(nNo(1), nNo(2), nNo(5), nNo(6), nNo(7)) + 1
nNoBonus(nNo(1), nNo(3), nNo(4), nNo(5), nNo(6)) = _
nNoBonus(nNo(1), nNo(3), nNo(4), nNo(5), nNo(6)) + 1
nNoBonus(nNo(1), nNo(3), nNo(4), nNo(5), nNo(7)) = _
nNoBonus(nNo(1), nNo(3), nNo(4), nNo(5), nNo(7)) + 1
nNoBonus(nNo(1), nNo(3), nNo(4), nNo(6), nNo(7)) = _
nNoBonus(nNo(1), nNo(3), nNo(4), nNo(6), nNo(7)) + 1
nNoBonus(nNo(1), nNo(3), nNo(5), nNo(6), nNo(7)) = _
nNoBonus(nNo(1), nNo(3), nNo(5), nNo(6), nNo(7)) + 1
nNoBonus(nNo(1), nNo(4), nNo(5), nNo(6), nNo(7)) = _
nNoBonus(nNo(1), nNo(4), nNo(5), nNo(6), nNo(7)) + 1
nNoBonus(nNo(2), nNo(3), nNo(4), nNo(5), nNo(6)) = _
nNoBonus(nNo(2), nNo(3), nNo(4), nNo(5), nNo(6)) + 1
nNoBonus(nNo(2), nNo(3), nNo(4), nNo(5), nNo(7)) = _
nNoBonus(nNo(2), nNo(3), nNo(4), nNo(5), nNo(7)) + 1
nNoBonus(nNo(2), nNo(3), nNo(4), nNo(6), nNo(7)) = _
nNoBonus(nNo(2), nNo(3), nNo(4), nNo(6), nNo(7)) + 1
nNoBonus(nNo(2), nNo(3), nNo(5), nNo(6), nNo(7)) = _
nNoBonus(nNo(2), nNo(3), nNo(5), nNo(6), nNo(7)) + 1
nNoBonus(nNo(2), nNo(4), nNo(5), nNo(6), nNo(7)) = _
nNoBonus(nNo(2), nNo(4), nNo(5), nNo(6), nNo(7)) + 1
nNoBonus(nNo(3), nNo(4), nNo(5), nNo(6), nNo(7)) = _
nNoBonus(nNo(3), nNo(4), nNo(5), nNo(6), nNo(7)) + 1
Next i
Sheets("Results").Select
Range("A1").Select
For i = 1 To nMaxF - 4
For j = i + 1 To nMaxF - 3
For k = j + 1 To nMaxF - 2
For l = k + 1 To nMaxF - 1
For m = l + 1 To nMaxF
nCount = nCount + 1
If nCount = 65501 Then
nCount = 1
ActiveCell.Offset(-65500, 8).Select
End If
ActiveCell.Offset(0, 0).Value = i
ActiveCell.Offset(0, 1).Value = j
ActiveCell.Offset(0, 2).Value = k
ActiveCell.Offset(0, 3).Value = l
ActiveCell.Offset(0, 4).Value = m
ActiveCell.Offset(0, 5).Value = nNoBonus(i, j, k,
l, m)
ActiveCell.Offset(0, 6).Value = nBonus(i, j, k, l,
m)
ActiveCell.Offset(1, 0).Select
Next m
Next l
Next k
Next j
Next i
Columns("A:IV").AutoFit
Columns("A:IV").HorizontalAlignment = xlCenter
Application.ScreenUpdating = True
End Sub
All the Best.
Paul
*** Sent via Developersdex http://www.developersdex.com ***
|