Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2329|回复: 6

[已解决]9个数字中只出现一次的数字

[复制链接]
发表于 2016-2-4 22:49 | 显示全部楼层 |阅读模式
Sub celia()
Dim rng As Range, mycount As Integer, a As Integer
For i = 1 To 9
If Cells(i, 1).Value Like "*5*" Then
mycount = mycount + 1
If mycount = 1 Then Cells(i, 1).Font.Size = 36
End If
Next i
End Sub
运行以上代码,可得右图: 1.png

9个格只有A3含有数字5.数字5在A1到A9中只出现一次。如果我想将代码改写,从A1到A9,数字1到9,在9个数字中只出现一次的数字,其所在单元格以36字体标明。代码应如何更改啊?


最佳答案
2016-2-5 11:23
  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
复制代码
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2016-2-5 06:28 | 显示全部楼层
  1. Sub Macro1()
  2. Dim arr, d, i&
  3. Set d = CreateObject("scripting.dictionary")
  4. arr = [a1:a9]
  5. [a1:a9].Font.Size = 12
  6. For i = 1 To UBound(arr)
  7.     x = arr(i, 1)
  8.     For j = 1 To Len(x)
  9.         s = Mid(x, j, 1)
  10.         If Not d.exists(s) Then
  11.             d(s) = i
  12.         Else
  13.             d(s) = ""
  14.         End If
  15.     Next
  16. Next
  17. b = d.items
  18. For i = 0 To d.Count - 1
  19.     If b(i) <> "" Then Cells(b(i), 1).Font.Size = 36
  20. Next
  21. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2016-2-5 09:35 | 显示全部楼层
dsmch 发表于 2016-2-5 06:28

谢谢您的宝贵意见,可惜运行无效
回复

使用道具 举报

发表于 2016-2-5 09:51 | 显示全部楼层
本帖最后由 dsmch 于 2016-2-5 09:54 编辑

附件…………

Book1.zip

7.24 KB, 下载次数: 4

回复

使用道具 举报

 楼主| 发表于 2016-2-5 10:07 | 显示全部楼层
dsmch 发表于 2016-2-5 06:28

你写的代码已经算很好了,我以前也为这个问题写过,可惜其实我们写的都不准确。都怪我未全面思考问题。 1.png 2.png
如果是左图的数据,用了您的代码运行后有右图效果。因为第7个宫也有个24,跟第一宫重复,所以不该36号字体显示的也显示了。您能否改善?

有待改善.zip

13.83 KB, 下载次数: 6

回复

使用道具 举报

发表于 2016-2-5 11:23 | 显示全部楼层    本楼为最佳答案   
  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
复制代码
回复

使用道具 举报

 楼主| 发表于 2016-2-5 16:42 | 显示全部楼层
dsmch 发表于 2016-2-5 11:23

好厉害
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 15:12 , Processed in 0.935544 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表