求大师给一个包含计数包含数字格式的VBA

飞越一切

非常感谢，见附件.

小凡、、、

-----------------

小凡、、、

瞎古巴举例，给哥们检查n多遍哪里写错了

dalyfreak

1. Sub main()
   
2.     Dim R1%, R2%, x%, y%, Z%, Sht1 As Worksheet, Sht2 As Worksheet
   
3.     Set Sht1 = Worksheets("原数1")
   
4.     Set Sht2 = Worksheets("统计数2")
   
5.     R1 = Sht1.UsedRange.Rows.Count
   
6.     R2 = Sht2.UsedRange.Rows.Count
   
7.     For y = 2 To 3
   
8.         ReDim tArr(6) As Integer
   
9.         For x = 2 To R1
   
10.             Dim n
    
11.             n = sameCot(Sht2.Cells(y, 1).Value, Sht1.Cells(x, 1).Value)
    
12.             If n > 0 Then
    
13.                 tArr(n - 1) = tArr(n - 1) + 1
    
14.             End If
    
15.         Next x
    
16.         For Z = 0 To 6
    
17.             Sht2.Cells(y, Z + 2).Value = tArr(Z)
    
18.         Next Z
    
19.     Next y
    
20. End Sub
    
21. 
    
22. Function sameCot(str1 As String, str2 As String) As Integer
    
23.     Dim iArr, i%, j%, Num%
    
24.     iArr = Split(str1, ",")
    
25.     j = UBound(iArr)
    
26.     For i = 0 To j
    
27.         If InStr(str2, iArr(i)) > 0 Then
    
28.             Num = Num + 1
    
29.         End If
    
30.     Next i
    
31.     sameCot = Num
    
32. End Function

复制代码

小凡、、、

定义了1-7，最大情况存在七组都相同的情况

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, cr, dr, i&, j&, k&, n&, r&, strJoin$
   
    Application.ScreenUpdating = False
   
    ar = Sheets("原数1").[A1].CurrentRegion.Value
    br = Sheets("统计数2").[A1].CurrentRegion.Value
    ReDim cr(UBound(ar) * UBound(br), 1)
   
    cr(0, 0) = "表1 的数": cr(0, 1) = "包含数"
    For i = 2 To UBound(br)
        strJoin = "," & br(i, 1) & ","
        For k = 2 To UBound(ar)
            dr = Split(ar(k, 1), ",")
            n = 0
            For j = 0 To UBound(dr)
                If InStr(strJoin, "," & dr(j) & ",") Then n = n + 1
            Next j
            r = r + 1
            cr(r, 0) = ar(k, 1): cr(r, 1) = n
        Next k
    Next i
   
    With Sheets("统计数2")
        .[I1].CurrentRegion.Clear
        .[I1].Resize(UBound(cr) + 1, 2) = cr
        .Activate
    End With
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

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

飞越一切

小凡、、、 发表于 2024-6-28 19:05
定义了1-7，最大情况存在七组都相同的情况

大师，数组变短或者变长，就显示错误，烦请改改

飞越一切

小凡、、、 发表于 2024-6-28 19:05
定义了1-7，最大情况存在七组都相同的情况

，大哥，这是啥情况，

飞越一切

gwjkkkkk 发表于 2024-6-28 20:15
.............

大哥，不是这样的