Question

我找到了一个带有常规模块和类模块的VBA代码，它们一起应该计算数据集中的重复次数。但是，我不断收到错误，我修复了代码上的小错误。任何人都可以在这里检查并告诉我这个问题。谢谢。

我收到的最后一个错误是在这一行：V(M, 1) = Vals(I)，以黄色突出显示。我认为问题出在常规模块中。

课程模块：

 Option Explicit
'Rename cQuad
Private pQ1 As Long
Private pQ2 As Long
Private pQ3 As Long
Private pQ4 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 Arr() As Variant
    Dim V(1 To 4)
        V(1) = Me.Q1
        V(2) = Me.Q2
        V(3) = Me.Q3
        V(4) = Me.Q4
    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

常规模块：

Sub CountForQuads()
    Dim cQ As cQuad, dQ As Dictionary, dID 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
Set dID = 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)
'    If V(J, 3) = 142 Then Stop
    Set cQ = New cQuad
        With cQ
            .Q1 = V(J, 1)
            .Q2 = V(J, 2)
            .Q2 = V(J, 3)
            .Q2 = V(J, 4)
            .Cnt = 1
'            .ID = V(J, 5)
            sKey = Join(.Arr, Chr(1))

            'Add one to the count if Quad already exists
            If Not dQ.Exists(sKey) Then
                dQ.Add sKey, cQ
                dID.Add sKey, V(J, 5)
            Else

                dQ(sKey).Cnt = dQ(sKey).Cnt + 1
               dID(sKey) = dID(sKey) & "," & V(J, 5)
            End If

        End With
    Next J
Next I

'Output the results
'set a threshold
Const TH As Long = 5

'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 5)

'Headers
vRes(0, 1) = "Value 1"
vRes(0, 2) = "Value 2"
vRes(0, 3) = "Value 3"
vRes(0, 4) = "Value 4"
vRes(0, 5) = "Count"
vRes(0, 6) = "ID Number"
'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) = .Cnt
            vRes(I, 6) = "'" & dID(V)
        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, M As Long
    Dim V

For I = 1 To UBound(Vals) - 3
    For J = I + 1 To UBound(Vals) - 2
        For K = J + 1 To UBound(Vals) - 1
            For L = K + 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)
            Next L
        Next K
    Next J
Next I


Combos = V

End Function

Answer 1

在Function Combos(Vals)的定义中，您尝试将V视为数组，即使您尚未初始化它也是如此。这只是一个空洞的变种。您需要为ReDim提供V声明。像这样：

Function Combos(Vals)
    Dim I As Long, J As Long, K As Long, L As Long, M As Long, n As Long
    Dim V As Variant
    n = UBound(Vals)
    ReDim V(1 To Application.WorksheetFunction.Combin(n, 4), 1 To 4)

    For I = 1 To n - 3
        For J = I + 1 To n - 2
            For K = J + 1 To n - 1
                For L = K + 1 To n
                    M = M + 1
                    V(M, 1) = Vals(I)
                    V(M, 2) = Vals(J)
                    V(M, 3) = Vals(K)
                    V(M, 4) = Vals(L)
                Next L
            Next K
        Next J
    Next I
    Combos = V

End Function

继续使用此VBA代码获取错误

1 个答案: