VBA help

mrc44

Board Regular
Joined
Aug 12, 2017
Messages
64
I keep getting out of memory error with this VBA script. and It highlights the following line :
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
 

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.

Forum statistics

Threads
1,223,164
Messages
6,170,444
Members
452,326
Latest member
johnshaji

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top