I keep getting out of memory error with this VBA script. and It highlights the following line :
Can someone help me please to fix this error? thanks.
This is the regular module:
and this is the class module:
Code:
ReDim V(1 To WorksheetFunction.Combin(UBound(Vals), 7), 1 To 7)
Can someone help me please to fix this error? thanks.
This is the regular module:
Code:
Option Explicit
'Set Reference to Microsoft Scripting Runtime
Sub ForQ()
Dim cQ As cQuad, dQ As Dictionary
Dim vSrc As Variant, vRes As Variant
Dim I As Long, J As Long
Dim wsData As Worksheet, wsRes As Worksheet, rRes As Range
Dim V, W
Dim sKey As String
Set wsData = Worksheets("Data")
Set wsRes = Worksheets("Results")
Set rRes = wsRes.Cells(1, 10)
With wsData
I = .Cells(.Rows.Count, 1).End(xlUp).Row 'Last Row
J = .Cells(1, .Columns.Count).End(xlToLeft).Column 'Last Column
vSrc = .Range(.Cells(1, 1), .Cells(I, J))
End With
Set dQ = New Dictionary
For I = 1 To UBound(vSrc, 1)
'Size array for number of combos in each row
V = Combos(Application.WorksheetFunction.Index(vSrc, I, 0))
'create an object for each Quad, including each member, and the count
For J = 1 To UBound(V, 1)
Set cQ = New cQuad
With cQ
.Q1 = V(J, 1)
.Q2 = V(J, 2)
.Q3 = V(J, 3)
.Q4 = V(J, 4)
.Q5 = V(J, 5)
.Q6 = V(J, 6)
.Q7 = V(J, 7)
.Cnt = 1
sKey = Join(.Arr, Chr(1))
'Add one to the count if Quad already exists
If Not dQ.Exists(sKey) Then
dQ.Add sKey, cQ
Else
dQ(sKey).Cnt = dQ(sKey).Cnt + 1
End If
End With
Next J
Next I
'Output the results
'set a threshold
Const TH As Long = 4
'Size the output array
I = 0
For Each V In dQ.Keys
If dQ(V).Cnt >= TH Then I = I + 1
Next V
ReDim vRes(0 To I, 1 To 8)
'Headers
vRes(0, 1) = "Value 1"
vRes(0, 2) = "Value 2"
vRes(0, 3) = "Value 3"
vRes(0, 4) = "Value 4"
vRes(0, 5) = "Value 5"
vRes(0, 6) = "Value 6"
vRes(0, 7) = "Value 7"
vRes(0, 8) = "Count"
'Output the data
I = 0
For Each V In dQ.Keys
Set cQ = dQ(V)
With cQ
If .Cnt >= TH Then
I = I + 1
vRes(I, 1) = .Q1
vRes(I, 2) = .Q2
vRes(I, 3) = .Q3
vRes(I, 4) = .Q4
vRes(I, 5) = .Q5
vRes(I, 6) = .Q6
vRes(I, 7) = .Q7
vRes(I, 8) = .Cnt
End If
End With
Next V
'Output the data
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
.EntireColumn.Clear
.Value = vRes
With .Rows(1)
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
.EntireColumn.AutoFit
.Sort key1:=.Columns(.Columns.Count), _
order1:=xlDescending, Header:=xlYes, MatchCase:=False
End With
End Sub
Function Combos(Vals)
Dim I As Long, J As Long, K As Long, L As Long, N As Long, P As Long, R As Long, M As Long
Dim V
ReDim V(1 To WorksheetFunction.Combin(UBound(Vals), 7), 1 To 7)
M = 0
For I = 1 To UBound(Vals) - 6
For J = I + 1 To UBound(Vals) - 5
For K = J + 1 To UBound(Vals) - 4
For L = K + 1 To UBound(Vals) - 3
For N = L + 1 To UBound(Vals) - 2
For P = N + 1 To UBound(Vals) - 1
For R = P + 1 To UBound(Vals)
M = M + 1
V(M, 1) = Vals(I)
V(M, 2) = Vals(J)
V(M, 3) = Vals(K)
V(M, 4) = Vals(L)
V(M, 5) = Vals(N)
V(M, 6) = Vals(P)
V(M, 7) = Vals(R)
Next R
Next P
Next N
Next L
Next K
Next J
Next I
Combos = V
End Function
and this is the class module:
Code:
Option Explicit
'Rename cQuad
Private pQ1 As Long
Private pQ2 As Long
Private pQ3 As Long
Private pQ4 As Long
Private pQ5 As Long
Private pQ6 As Long
Private pQ7 As Long
Private pCnt As Long
Private pArr As Variant
Public Property Get Q1() As Long
Q1 = pQ1
End Property
Public Property Let Q1(Value As Long)
pQ1 = Value
End Property
Public Property Get Q2() As Long
Q2 = pQ2
End Property
Public Property Let Q2(Value As Long)
pQ2 = Value
End Property
Public Property Get Q3() As Long
Q3 = pQ3
End Property
Public Property Let Q3(Value As Long)
pQ3 = Value
End Property
Public Property Get Q4() As Long
Q4 = pQ4
End Property
Public Property Let Q4(Value As Long)
pQ4 = Value
End Property
Public Property Get Q5() As Long
Q5 = pQ5
End Property
Public Property Let Q5(Value As Long)
pQ5 = Value
End Property
Public Property Get Q6() As Long
Q6 = pQ6
End Property
Public Property Let Q6(Value As Long)
pQ6 = Value
End Property
Public Property Get Q7() As Long
Q7 = pQ7
End Property
Public Property Let Q7(Value As Long)
pQ7 = Value
End Property
Public Property Get Arr() As Variant
Dim V(1 To 7)
V(1) = Me.Q1
V(2) = Me.Q2
V(3) = Me.Q3
V(4) = Me.Q4
V(5) = Me.Q5
V(6) = Me.Q6
V(7) = Me.Q7
Arr = V
End Property
Public Property Get Cnt() As Long
Cnt = pCnt
End Property
Public Property Let Cnt(Value As Long)
pCnt = Value
End Property