麻烦写个数字的亲疏加减

半百

1. Sub 亲疏加减()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. s = "89012345678901234567890123456789"
   
4. br = [{1,6,4,9;1,2,8,9;"亲","疏","加","减"}]
   
5. For i = 0 To 9
   
6.     For j = 1 To 4
   
7.         d(i & br(3, j)) = Mid(s, i + br(1, j), 5)
   
8.     Next
   
9. Next
   
10. With ActiveSheet.UsedRange.Resize(, 34)
    
11.     .Offset(3, 2).Clear
    
12.     ar = .Value
    
13.     For i = 4 To UBound(ar)
    
14.         If ar(i, 2) = "" Then Exit For
    
15.         For j = 1 To 3
    
16.             s = Mid(ar(i, 2), j, 1)
    
17.             For k = 1 To 4
    
18.                 ar(i, br(2, k) + j * 2) = d(s & br(3, k))
    
19.             Next
    
20.             ar(i, 16) = ar(i, 16) & IIf(InStr(ar(i - 1, 1 + j * 2), s) > 0, "亲", "疏")
    
21.             ar(i, 17) = ar(i, 17) & IIf(InStr(ar(i - 1, 8 + j * 2), s) > 0, "加", "减")
    
22.         Next
    
23.         ar(4, 16) = "": ar(4, 17) = ""
    
24.         For j = 18 To 25
    
25.         If ar(i, 16) = ar(3, j) Then
    
26.             ar(i, j) = ar(3, j)
    
27.             Cells(i, j).Interior.ColorIndex = 3
    
28.         Else
    
29.             ar(i, j) = Val(ar(i - 1, j)) + 1
    
30.         End If
    
31.         If ar(i, 17) = ar(3, j + 9) Then
    
32.             ar(i, j + 9) = ar(3, j + 9)
    
33.             Cells(i, j + 9).Interior.ColorIndex = 3
    
34.         Else
    
35.             ar(i, j + 9) = Val(ar(i - 1, j + 9)) + 1
    
36.         End If
    
37.         Next
    
38.     Next
    
39.     .Value = ar
    
40. End With
    
41. End Sub

复制代码

nihao123456789

我也来个。

不可说7625

清风竹- 发表于 2025-3-31 10:02
请测试。。

能修改成下图吗？
把每个亲疏、加减组合数字填进去，并标红。

清风竹-

不可说7625 发表于 2025-4-2 22:50
能修改成下图吗？
把每个亲疏、加减组合数字填进去，并标红。

请测试。。

不可说7625

清风竹- 发表于 2025-4-3 12:31
请测试。。

这行没有列出数字范围。要怎么改下？

清风竹-

不可说7625 发表于 2025-4-3 22:32
这行没有列出数字范围。要怎么改下？

请测试。。

不可说7625

清风竹- 发表于 2025-4-4 13:27
请测试。。

运行好慢要怎么弄？

ynzsvt

不可说7625 发表于 2025-4-4 20:23
运行好慢要怎么弄？

数据多，又要搞颜色，快不了

不可说7625

清风竹- 发表于 2025-4-4 13:27
请测试。。

麻烦在修改成如图。谢谢。

不可说7625

清风竹- 发表于 2025-4-4 13:27
请测试。。

老师，有空在弄下吗