请教大神一个关于求交集的数字矩阵问题，望不吝赐教，谢谢

OperaMobile

如下图，我想用VBA模块来制作一张表，模拟结果如下：

已知A列数据可能超过一万行，从第一行开始，一次取三行数字，分别加1，得出的三个数，如果<=18则保持原值，如果>18则减去18，如图A1:A3+1的结果就是D1:D3，然后求D1:D3与H1:H3交集的数量，将结果1写入K1，然后逐次开始向下取A2:A4的数字加1按上述规则计算后与H1:H3求交集的数量，并写入K2,接下来是A3：A5，一直计算到最后一行，填完完成K列的数字后，接下来把加数变为2，同样按照上述的计算规则计算出一列交集数量的数组填入K列，依次类推，一直到把加数加到18为止，一直填充到AB列，完成一个数字矩阵。要求A列数据保持不变，D1:D3和B2的数字只是为了做说明，实际不在表格中，写了很多，不知道把问题说清楚没有，望大神不吝赐教，感激不尽!

数字矩阵问题.rar (36.49 KB, 下载次数: 10)

2024-4-29 23:23 上传

点击文件名下载附件

DevilW

原 ar(i, 1) Mod 18 + j 改为 (ar(i, 1) Mod 18 + j) Mod 19

1. Sub test()
   
2.     Set reg = CreateObject("vbScript.Regexp")
   
3.     reg.Global = True
   
4.     reg.Pattern = "\b(15|6|7)\b"
   
5.     ar = Range([a1], [a65536].End(3))
   
6.     ReDim br(1 To UBound(ar), 1 To 18)
   
7.     cr = br
   
8.     For i = 1 To UBound(ar)
   
9.         For j = 1 To 18
   
10.             s = (ar(i, 1) Mod 18 + j) Mod 19
    
11.             If reg.test(s) Then br(i, j) = "a" Else br(i, j) = "b"
    
12.         Next
    
13.     Next
    
14.     For i = 1 To 18
    
15.         t = " " & br(1, i) & br(2, i)
    
16.         For j = 3 To UBound(ar)
    
17.             t = Mid(t, 2) & br(j, i)
    
18.             cr(j - 2, i) = Len(Replace(t, "b", ""))
    
19.         Next
    
20.     Next
    
21.     [k1].Resize(UBound(ar), 18) = cr
    
22. End Sub
    

复制代码

gwjkkkkk

Option Explicit
Sub TEST4()
    Dim ar, br, cr, vResult, i&, j&, k&, n&, strJoin$, t#
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    t = Timer
   
    ar = Range("A1", Cells(Rows.Count, "A").End(xlUp)).Value
    br = Range("H1:H3").Value
    ReDim cr(2)
    ReDim vResult(1 To UBound(ar) - 2, 1 To 18)
    For i = 1 To UBound(ar) - 2
        For j = 1 To UBound(vResult, 2)
            For k = 0 To 2
                cr(k) = ar(i + k, 1) + j
                cr(k) = IIf(cr(k) > 18, cr(k) - 18, cr(k))
            Next k
            n = 0
            strJoin = "," & Join(cr, ",") & ","
            For k = 1 To UBound(br)
                If InStr(strJoin, "," & br(k, 1) & ",") Then n = n + 1
            Next k
            vResult(i, j) = n
        Next j
    Next i
   
    [K1].Resize(UBound(vResult), UBound(vResult, 2)) = vResult
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "执行完毕!_用时:  " & Format(Timer - t, "0.00") & "  秒", 64
End Sub

gwjkkkkk

请参考附件。。。

OperaMobile

DevilW 发表于 2024-4-30 01:31
原 ar(i, 1) Mod 18 + j 改为 (ar(i, 1) Mod 18 + j) Mod 19

大神你好！如果将A列最后三行数字作为固定的求交集数量的变量数组，取代先前D1:D3的常量数组，其余规则不变，应该如何修改上述代码呢，望不吝赐教，谢谢

OperaMobile

gwjkkkkk 发表于 2024-4-30 06:20
请参考附件。。。

非常感谢您在百忙中抽空帮忙。

DevilW

OperaMobile 发表于 2024-4-30 13:17
大神你好！如果将A列最后三行数字作为固定的求交集数量的变量数组，取代先前D1:D3的常量数组，其余规则不 ...

改用字典比较