统计出现频率大于某数的所有情况

风波亭

1.EY2:FR2任意选两个，对应下面的EY3:FR10000区域内的数字必须大于0，去找这样的组合，且这种组合出现的次数要大于2次，并显示出来，低于2次的不显示。
2.例如，组合27，共出现2次分别在第3.10行，就显示出来.而1.5共出现1次，就不显示。
3.结果放到sheet2，的A2:B3里面
4.由于实际EY3:FR10000数据非常多，甚至超过1000万，所以耗时不能太久。

gwjkkkkk

Option Explicit
Sub TEST7()
    Dim vResult, ar, br, cr, i&, j&, k&, r&, strJoin$, t#
   
    Application.ScreenUpdating = False
    t = Timer
   
    r = Cells(Rows.Count, "EY").End(xlUp).Row
    ar = Range("EY3:FR" & r).Value
   
    br = combinArr2(UBound(ar, 2), 2)
    ReDim vResult(1 To UBound(br), 1 To 4)
    r = 0
    For i = 1 To UBound(br)
        strJoin = ""
        For k = 1 To UBound(ar)
            If ar(k, br(i, 1)) = 1 And ar(k, br(i, 2)) = 1 Then strJoin = strJoin & " " & k
        Next k
        cr = Split(strJoin)
        If UBound(cr) > 1 Then
            r = r + 1
            strJoin = ""
            vResult(r, 1) = br(i, 1)
            vResult(r, 2) = br(i, 2)
            vResult(r, 3) = UBound(cr)
            For j = 1 To UBound(cr)
                strJoin = strJoin & ".第" & cr(j) + 2
            Next j
            vResult(r, 4) = Mid(strJoin, 2) & "行"
        End If
    Next i
   
    [FT3].CurrentRegion.Offset(1).ClearContents
    [FT3].Resize(r, UBound(vResult, 2)) = vResult
   
    Application.ScreenUpdating = True
    MsgBox "执行完毕!_用时:  " & Format(Timer - t, "0.00") & "  秒", 64
End Sub

Function combinArr2(ByVal m&, ByVal n&)
    Dim br&(), vResult, i&, j&, iCount&, iGroup&, vTemp

    iGroup = Application.Combin(m, n)
    ReDim vResult(1 To iGroup, 1 To n)
    ReDim br&(1 To n)
    If n = 1 Then
        For i = 1 To iGroup
            vResult(i, 1) = i
        Next i
        combinArr2 = vResult
        Exit Function
    End If
    For j = 1 To n - 1: br(j) = j: Next
    iCount = 0
   
    Do
        For i = br(n - 1) + 1 To m
            br(n) = i
            iCount = iCount + 1
            For j = 1 To n
                vResult(iCount, j) = br(j)
            Next j
        Next
        If br(n - 1) < br(n) - 1 Then
            br(n - 1) = br(n - 1) + 1
        Else
            For j = n - 2 To 1 Step -1
                If br(j) <> br(j + 1) - 1 Then
                    vTemp = br(j) + 1: br(j) = vTemp: j = j + 1
                    Do Until j = n
                        br(j) = br(j - 1) + 1: j = j + 1
                    Loop
                    Exit For
                End If
            Next
        End If
    Loop Until iCount = iGroup
    combinArr2 = vResult
End Function

gwjkkkkk

.......................

风波亭

gwjkkkkk 发表于 2024-6-15 17:55
.......................

谢谢，大佬