[已解决]求保留特定数字的精简代码

lingyuncelia1 · 发表于 2016-2-11 21:00

如上图示，在A1到I1中，数字1到9，只出现两次的数字有：1、5、7.
现求一代码，凡出现2次的数字中，任意2个数字都出现在同一单元格的，清保留该2个数字，并以36号字体显示。
得到如下效果：

运行以下代码即可：
Sub 数字变文本()
Sheet2.Range("A1:I1").FormulaR1C1 = "=TEXT(sheet1!RC,0)"
Sheet2.Range("A1:I1").Copy
Sheet1.Range("A1:I1").PasteSpecial Paste:=xlPasteValues
Sheet2.Range("A1:I1").Clear
Sheet1.Activate
Call 查找出现2次的数字
Call 保留同行隐含对数
Range("k1").ClearContents
End Sub
Sub 查找出现2次的数字()
Dim mycount As Integer, a As Integer, j As Integer
For j = 1 To 9
  For a = 1 To 9
  xstr = ""
mycount = Application.WorksheetFunction.CountIf(Rows(1), "*" & a & "*")
If mycount = 2 And Cells(1, j).Value Like "*" & a & "*" Then Cells(a, 10) = a
Next a
Next j
xstr = ""
Dim x As Range
For Each x In Range("j1:j9")
If x <> "" Then xstr = xstr & x
Next
Cells(1, 11) = xstr
Columns("J:J").ClearContents
End Sub
Sub 保留同行隐含对数()
Dim reg, s As Range, m
For i = 1 To Len(Cells(1, 11))
      If b = "" Then b = Mid(Cells(1, 11), i, 1) Else b = b & "," & Mid(Cells(1, 11), i, 1)
Next
Set reg = CreateObject("vbscript.regexp")
With reg
      .Global = True
      .Pattern = "[" & b & "]"
      For Each s In Range("a1:i1")
         Set m = reg.Execute(s.Value)
         If m.Count = 2 Then
            Range(s.Address) = m.Item(0).Value & m.Item(1).Value
            Range(s.Address).Font.Size = 36
         End If
      Next
End With
Set reg = Nothing
End Sub
问题是代码太长了，有没有哪位大神可以写得出更精简的代码？

最佳答案

月排行榜 / 总排行榜

dsmch

2016-2-11 22:33

本帖最后由 dsmch 于 2016-2-11 22:37 编辑

Sub Macro1()
Dim arr, d, d2, i%, j%
Set d = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
[a1:i1].Font.Size = 11
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

复制代码

跳转到最佳答案楼层

dsmch · 发表于 2016-2-11 22:33

本帖最后由 dsmch 于 2016-2-11 22:37 编辑

Sub Macro1()
Dim arr, d, d2, i%, j%
Set d = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
[a1:i1].Font.Size = 11
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

复制代码

lingyuncelia1 · 发表于 2016-2-12 09:48

dsmch 发表于 2016-2-11 22:33

高手：

如图示，运行以下代码，得出的结果是Cells(1,10)=7.只出现2次数字的是：1、5、7。原本以为以下代码会使Cells(1,10)=157,但为什么这个代码是在J1先后写入1、5、7，最后只保留7呢？
Sub Celia()
Dim mycount As Integer, a As Integer, j As Integer
For j = 1 To 9
  For a = 1 To 9
  xstr = ""
mycount = Application.WorksheetFunction.CountIf(Rows(1), "*" & a & "*")
If mycount = 2 And Cells(1, j).Value Like "*" & a & "*" Then
xstr = xstr & a
Cells(1, 10) = xstr
End If
Next a
Next j
End Sub
如果要一次性保留157，代码该如何写？当然我自己也写得出，可惜超长。我先将其变文本，然后另起一列计算等等，长到以下这个样子。如果是你，解题思路是什么啊？
Sub 同行隐含对数()
'数字变文本
Sheet2.Range("A1:I1").FormulaR1C1 = "=TEXT(sheet1!RC,0)"
Sheet2.Range("A1:I1").Copy
Sheet1.Range("A1:I1").PasteSpecial Paste:=xlPasteValues
Sheet2.Range("A1:I1").Clear
Sheet1.Activate
Call 查找出现2次的数字
Call 保留同行隐含对数
Range("k1").ClearContents
End Sub
Sub 查找出现2次的数字()
Dim mycount As Integer, a As Integer, j As Integer
For j = 1 To 9
  For a = 1 To 9
  xstr = ""
mycount = Application.WorksheetFunction.CountIf(Rows(1), "*" & a & "*")
If mycount = 2 And Cells(1, j).Value Like "*" & a & "*" Then Cells(a, 10) = a
Next a
Next j
xstr = ""
Dim x As Range
For Each x In Range("j1:j9")
If x <> "" Then xstr = xstr & x
Next
Cells(1, 11) = xstr
Columns("J:J").ClearContents
End Sub

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