提取不重复值到一单元格多了个逗号

张雄友

提取不重复值到一单元格多了个逗号?

yjh_27

Sub 提取不重复值到一单元格()
On Error GoTo err
Dim arr, x&, Str$, d As Object, rng As Range
arr = Application.InputBox("请选择数据源", "提示", , , , , , 8)
Set d = CreateObject("scripting.dictionary")
For x = 2 To UBound(arr)
    If Not d.exists(arr(x, 1)) And Not IsError(arr(x, 1)) And Not IsEmpty(arr(x, 1)) Then
        Str = Str & "," & arr(x, 1)
    End If
    d(arr(x, 1)) = ""
Next
Set rng = Application.InputBox("请选择存放地址", "提示", , , , , , 8)
rng = "'" & Mid(Str, 2)
err:
End Sub

zax010

Sub 提取不重复值到一单元()
    On Error GoTo err
    Dim arr, x&, Str$, d As Object, rng As Range
    arr = Application.InputBox("请选择数据源", "提示", , , , , , 8)
    Set d = CreateObject("scripting.dictionary")
    For x = 1 To UBound(arr)
        If arr(x, 1) <> "" Then
            d(arr(x, 1)) = ""
        End If
err:
    Next
    Set rng = Application.InputBox("请选择存放地址", "提示", , , , , , 8)
    rng = Join(d.keys, ",")
End Sub

张雄友

zax010 发表于 2014-7-8 20:40
Sub 提取不重复值到一单元()
    On Error GoTo err
    Dim arr, x&, Str$, d As Object, rng As Range
...

如果点取消时会出错。运行时错误424,要求对象。

bluexuemei

1. 
   
2. Sub t()
   
3. '需要安装ACTIVERUBY ，下载地址 http://www.artonx.org/data/asr/Ruby-2.1.1.msi
   
4. Set ojs = CreateObject("scriptcontrol"): ojs.Language = "rubyscript"
   
5. ojs.eval ("def aa(aa);$aa=aa.flatten;end")
   
6. y = ojs.Run("aa", Range("a2", [a65536].End(3)).Value)
   
7. y = ojs.eval("$aa.uniq.select{|x|!x.is_a? Integer}.compact.map{|x|(x.is_a?Float)?(x.to_i):x}.join(',')")
   
8. [d2] = y
   
9. Set ojs = Nothing
   
10. 'Stop
    
11. End Sub
    

复制代码

zax010

张雄友 发表于 2014-7-8 20:57
如果点取消时会出错。运行时错误424,要求对象。

学习2楼大师的判断方法处理空值和错误值：
Sub 提取不重复值到一单元()
    Dim arr, x&, d As Object, rng As Range
    arr = Application.InputBox("请选择数据源", "提示", , , , , , 8)
    Set d = CreateObject("scripting.dictionary")
    On Error GoTo err
    For x = 1 To UBound(arr)
        If Not IsError(arr(x, 1)) And Not IsEmpty(arr(x, 1)) Then
            d(arr(x, 1)) = ""
        End If
    Next
    Set rng = Application.InputBox("请选择存放地址", "提示", , , , , , 8)
    rng.Value = Join(d.keys, ",")
err:
End Sub

zax010

张雄友 发表于 2014-7-8 20:57
如果点取消时会出错。运行时错误424,要求对象。

除学习2楼大师的方法外，把 Set rng =...句移到  err:的前面，输出加一个判断条件，搞定：

Sub 提取不重复值到一单元()
    Dim arr, x&, d As Object, rng As Range
    On Error GoTo err
    arr = Application.InputBox("请选择数据源", "提示", , , , , , 8)
    Set d = CreateObject("scripting.dictionary")
    Set rng = Application.InputBox("请选择存放地址", "提示", , , , , , 8)
    For x = 1 To UBound(arr)
        If arr(x, 1) <> "" Then
            d(arr(x, 1)) = ""
        End If
err:
    Next
    If Not rng Is Nothing Then rng.Value = Join(d.keys, ",")
End Sub

这个题目，去重复、出结果比较容易，但稍不留意，错误处理就出毛病了。