[已解决]如何让每宫的两位相同数字用字体36显示出来

lingyuncelia1

关于数独问题，9格为一宫，如何让每宫的两位相同数字用字体36显示出来，做到如下效果呢？VBA代码应如何写呢？

最佳答案

月排行榜 / 总排行榜

dsmch

2016-2-5 07:22

1. Sub Macro1()
   
2. Dim arr, d, i&, j%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = [a1:i9]
   
5. [a1:i9].Font.Size = 12
   
6. For i = 1 To UBound(arr)
   
7.     For j = 1 To UBound(arr, 2)
   
8.         s = arr(i, j)
   
9.         If Len(s) = 2 Then
   
10.             If Not d.exists(s) Then
    
11.                 d(s) = Cells(i, j).Address
    
12.             Else
    
13.                 d(s) = d(s) & "," & Cells(i, j).Address
    
14.             End If
    
15.         End If
    
16.     Next
    
17. Next
    
18. b = d.items
    
19. For i = 0 To d.Count - 1
    
20.     If InStr(b(i), ",") Then Range(b(i)).Font.Size = 36
    
21. Next
    
22. End Sub

复制代码

跳转到最佳答案楼层

wanao2008

我想到两种方法，一是用>10 and <100 来判断，一是用len()=2来判断，不知道行不行？

lingyuncelia1

wanao2008 发表于 2016-2-4 19:48
我想到两种方法，一是用>10 and

是不行的

dsmch

1. Sub Macro1()
   
2. Dim arr, d, i&, j%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = [a1:i9]
   
5. [a1:i9].Font.Size = 12
   
6. For i = 1 To UBound(arr)
   
7.     For j = 1 To UBound(arr, 2)
   
8.         s = arr(i, j)
   
9.         If Len(s) = 2 Then
   
10.             If Not d.exists(s) Then
    
11.                 d(s) = Cells(i, j).Address
    
12.             Else
    
13.                 d(s) = d(s) & "," & Cells(i, j).Address
    
14.             End If
    
15.         End If
    
16.     Next
    
17. Next
    
18. b = d.items
    
19. For i = 0 To d.Count - 1
    
20.     If InStr(b(i), ",") Then Range(b(i)).Font.Size = 36
    
21. Next
    
22. End Sub

复制代码

dsmch

最简单的方法设置条件格式
选中a1:i9,设置条件格式，公式=AND(LEN(A1)=2,COUNTIF($A$1:$I$9,A1)>1)，设置格式

lingyuncelia1

dsmch 发表于 2016-2-5 07:32
最简单的方法设置条件格式
选中a1:i9,设置条件格式，公式=AND(LEN(A1)=2,COUNTIF($A$1:$I$9,A1)>1)，设置格 ...

我知道最方便当然不是写VBA代码，但是我是准备自己设计九宫游戏自己玩的。我发个附件给你看看，你就明白为什么要用VBA了。觉得我设计得如何，这个数独游戏感觉如何，您能正确填写所有数字吗？我们全办公室都无人填得出。

dsmch

理解有误，修正一下代码

1. Sub Macro1()
   
2. Dim arr, d, i%, j%, k%, h%, l%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. [a1:i9].Font.Size = 12
   
5. For h = 1 To 7 Step 3
   
6.     For l = 1 To 7 Step 3
   
7.         arr = Cells(h, l).Resize(3, 3)
   
8.         For i = 1 To 3
   
9.             For j = 1 To 3
   
10.                 s = arr(i, j)
    
11.                 If Len(s) = 2 Then
    
12.                     If Not d.exists(s) Then
    
13.                         d(s) = Cells(h + i - 1, l + j - 1).Address
    
14.                     Else
    
15.                         d(s) = d(s) & "," & Cells(h + i - 1, l + j - 1).Address
    
16.                     End If
    
17.                 End If
    
18.             Next
    
19.         Next
    
20.         b = d.items
    
21.         For k = 0 To d.Count - 1
    
22.             If InStr(b(k), ",") Then Range(b(k)).Font.Size = 36
    
23.         Next
    
24.         d.RemoveAll
    
25.     Next
    
26. Next
    
27. End Sub

复制代码