[已解决]求同行循环简写代码

lingyuncelia1 · 发表于 2016-2-14 19:37

如上图示，运行以下代码：
Sub Macro1()
Dim arr, d, d2, i%, j%
Set d = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
arr = [a1:i1]
For j = 1 To UBound(arr, 2)
x = arr(1, j)
For i = 1 To Len(x)
      s = Mid(x, i, 1)
      d(s) = d(s) + 1
Next
Next
For Each a In d.keys
If d(a) = 2 Then d2(a) = ""
Next
For j = 1 To UBound(arr, 2)
x = arr(1, j)
p = ""
For i = 1 To Len(x)
      s = Mid(x, i, 1)
      If d2.exists(s) Then p = p & s
Next
If Len(p) = 2 Then Cells(1, j) = p: Cells(1, j).Font.Size = 36
Next
End Sub
得到如下效果：

代码只对第一行有效，如果我想对9行都有效，应如何改善代码？
发觉代码只要更改黄色背景字的区域即可，但写类似同样的9个代码实在太麻烦了。
能否在此代码基础上改善？哪位大神可以啊？可以得出如下效果：

最佳答案

月排行榜 / 总排行榜

dsmch

2016-2-14 20:05

Sub Macro1()
Dim arr, d, d2, i%, j%, k%
Set d = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
For k = 1 To 9
arr = Cells(k, 1).Resize(1, 9)
For j = 1 To UBound(arr, 2)
x = arr(1, j)
For i = 1 To Len(x)
s = Mid(x, i, 1)
d(s) = d(s) + 1
Next
Next
For Each a In d.keys
If d(a) = 2 Then d2(a) = ""
Next
For j = 1 To UBound(arr, 2)
x = arr(1, j)
p = ""
For i = 1 To Len(x)
s = Mid(x, i, 1)
If d2.exists(s) Then p = p & s
Next
If Len(p) = 2 Then Cells(k, j) = p: Cells(k, j).Font.Size = 36
Next
d.RemoveAll: d2.RemoveAll
Next
End Sub

复制代码

跳转到最佳答案楼层

dsmch · 发表于 2016-2-14 20:05

Sub Macro1()
Dim arr, d, d2, i%, j%, k%
Set d = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
For k = 1 To 9
arr = Cells(k, 1).Resize(1, 9)
For j = 1 To UBound(arr, 2)
x = arr(1, j)
For i = 1 To Len(x)
s = Mid(x, i, 1)
d(s) = d(s) + 1
Next
Next
For Each a In d.keys
If d(a) = 2 Then d2(a) = ""
Next
For j = 1 To UBound(arr, 2)
x = arr(1, j)
p = ""
For i = 1 To Len(x)
s = Mid(x, i, 1)
If d2.exists(s) Then p = p & s
Next
If Len(p) = 2 Then Cells(k, j) = p: Cells(k, j).Font.Size = 36
Next
d.RemoveAll: d2.RemoveAll
Next
End Sub

复制代码

		自动登录	找回密码
密码			注册