[已解决]相同加1请高手给个VBA解法

东方智彩

看附件,请高手给个VBA解法,谢谢
Book1.rar (1.94 KB, 下载次数: 22)

2012-1-20 15:47 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

liuts

2012-1-20 16:56

1. Option Explicit
   
2. Sub liuts()
   
3.     Dim arr, sr$, s$, i%, x As Byte, dic As Object, srg$, Ar, j%, brr()
   
4.     Set dic = CreateObject("scripting.dictionary")
   
5.     arr = Range("b4:b7")
   
6.     ReDim brr(1 To UBound(arr))
   
7.     For j = 1 To UBound(arr)
   
8.         sr = arr(j, 1)
   
9.         x = Len(sr): srg = "": dic.RemoveAll
   
10.         For i = 1 To x
    
11.             s = Mid(sr, i, 1)
    
12.             If Not dic.Exists(s) Then
    
13.                 dic.Add s, Array(s, 0)
    
14.             Else
    
15.                 Ar = dic(s)
    
16.                 Ar(1) = Ar(1) + 1
    
17.                 Ar(0) = Right(s + Ar(1), 1)
    
18.                 dic(s) = Ar
    
19.             End If
    
20.             srg = srg & dic(s)(0)
    
21.         Next
    
22.         brr(j) = srg
    
23.     Next
    
24.     Range("c4").Resize(UBound(brr)) = Application.Transpose(brr)
    
25. End Sub

复制代码

前期绑定换成后期绑定就可以了

跳转到最佳答案楼层

hytsky

跟个帖学习一下下····

liuts

1. Option Explicit
   
2. Sub liuts()
   
3.     Dim arr, sr$, s$, i%, x As Byte, dic As Object, srg$, Ar, j%, brr()
   
4.     Set dic = CreateObject("scripting.dictionary")
   
5.     arr = Range("b4:b7")
   
6.     ReDim brr(1 To UBound(arr))
   
7.     For j = 1 To UBound(arr)
   
8.         sr = arr(j, 1)
   
9.         x = Len(sr): srg = "": dic.RemoveAll
   
10.         For i = 1 To x
    
11.             s = Mid(sr, i, 1)
    
12.             If Not dic.Exists(s) Then
    
13.                 dic.Add s, Array(s, 0)
    
14.             Else
    
15.                 Ar = dic(s)
    
16.                 Ar(1) = Ar(1) + 1
    
17.                 Ar(0) = Right(s + Ar(1), 1)
    
18.                 dic(s) = Ar
    
19.             End If
    
20.             srg = srg & dic(s)(0)
    
21.         Next
    
22.         brr(j) = srg
    
23.     Next
    
24.     Range("c4").Resize(UBound(brr)) = Application.Transpose(brr)
    
25. End Sub

复制代码

前期绑定换成后期绑定就可以了

东方智彩

dic As New Dictionary
代码测试出现这个情况,请版主修改,谢谢!

wenchduan

上面版主的代码真的看不懂啊，得好好学习

东方智彩

谢谢版主代码测试正解,学习了

BAIXINGR

学习了