[已解决]求助2个VBA

mate33

求助2个VBA

最佳答案

月排行榜 / 总排行榜

grf1973

2017-6-9 13:07

Sub 正向()
    arr = Range("e1:e" & [e65536].End(3).Row)
    For i = 1 To UBound(arr)
        x = arr(i, 1)
        For m = 1 To Len(x)
            xstr = xstr & Mid(x, m, 1)
        Next
    Next
    'xstr = StrReverse(xstr)   '加此句则为反向（字符串反转）
   
    Set d = CreateObject("scripting.dictionary")
    brr = Range("f1:f" & [f65536].End(3).Row + 1)
    For i = 1 To UBound(brr)
        If Len(brr(i, 1)) > 0 Then d(brr(i, 1)) = ""
    Next
   
    ReDim crr(1 To 1000, 1 To 1)
    For n = 0 To 999
        p = (n + 1) Mod Len(xstr)
        If p = 0 Then p = Len(xstr)
        myF = Val(Mid(xstr, p, 1))
        If d.exists(myF) Then
            k = k + 1
            crr(k, 1) = n
        End If
    Next
   
    [H:H].Clear
    If k > 0 Then [H1].Resize(k) = crr
    [H1].Resize(k).NumberFormatLocal = "000"
End Sub

跳转到最佳答案楼层

grf1973

1. Sub 正向()
   
2.     arr = Range("e1:e" & [e65536].End(3).Row)
   
3.     For i = 1 To UBound(arr)
   
4.         x = arr(i, 1)
   
5.         For m = 1 To Len(x)
   
6.             xstr = xstr & Mid(x, m, 1)
   
7.         Next
   
8.     Next
   
9.     'xstr = StrReverse(xstr)   '加此句则为反向（字符串反转）
   
10.    
    
11.     Set d = CreateObject("scripting.dictionary")
    
12.     brr = Range("f1:f" & [f65536].End(3).Row)
    
13.     For i = 1 To UBound(brr)
    
14.         d(brr(i, 1)) = ""
    
15.     Next
    
16.    
    
17.     ReDim crr(1 To 1001, 1 To 1)
    
18.     For n = 0 To 1000
    
19.         p = (n + 1) Mod Len(xstr)
    
20.         If p = 0 Then p = Len(xstr)
    
21.         myF = Val(Mid(xstr, p, 1))
    
22.         If d.exists(myF) Then
    
23.             k = k + 1
    
24.             crr(k, 1) = n
    
25.         End If
    
26.     Next
    
27.    
    
28.     [H:H].Clear
    
29.     If k > 0 Then [H1].Resize(k) = crr
    
30.     [H1].Resize(k).NumberFormatLocal = "000"
    
31. End Sub
    

复制代码

mate33

grf1973 发表于 2017-6-8 14:15

发现有2个小错误，麻烦老师看下。
1.H列提取的结果有的时候会多了一个1000，编号是000-999，最大编号只999 。麻烦老师看下。
2.当F列给定的数据只一个数字时，代码错误，不能运行。

mate33

再顶下求解。

mate33

有没老师完善下代码的

grf1973

Sub 正向()
    arr = Range("e1:e" & [e65536].End(3).Row)
    For i = 1 To UBound(arr)
        x = arr(i, 1)
        For m = 1 To Len(x)
            xstr = xstr & Mid(x, m, 1)
        Next
    Next
    'xstr = StrReverse(xstr)   '加此句则为反向（字符串反转）
   
    Set d = CreateObject("scripting.dictionary")
    brr = Range("f1:f" & [f65536].End(3).Row + 1)
    For i = 1 To UBound(brr)
        If Len(brr(i, 1)) > 0 Then d(brr(i, 1)) = ""
    Next
   
    ReDim crr(1 To 1000, 1 To 1)
    For n = 0 To 999
        p = (n + 1) Mod Len(xstr)
        If p = 0 Then p = Len(xstr)
        myF = Val(Mid(xstr, p, 1))
        If d.exists(myF) Then
            k = k + 1
            crr(k, 1) = n
        End If
    Next
   
    [H:H].Clear
    If k > 0 Then [H1].Resize(k) = crr
    [H1].Resize(k).NumberFormatLocal = "000"
End Sub