1

最近我在 Stack Overflow 上发现了一个非常好的脚本。它工作得很好，但我想稍微调整一下——尽管我的技能仍然不能让我非常喜欢这种 VBA。到目前为止，我只是未能重新编写此代码。

我的目标是让这个脚本做它做的事情，但是从一个固定的位置 - 所以我不想通过“问题框”选择它，而是复制一个数据范围。例如：A1:A200并将其粘贴到另一个选项卡中，例如：DATA!A1:A200

你可以帮帮我吗？

和代码：

Sub ListUniqueValues()

 'lists the unique values found in a user-defined range into a
 'user-defined columnar range

 Dim SearchRng     As Range
 Dim ResultRng     As Range
 Dim Cel          As Range
 Dim iRow          As Long

 Set SearchRng = Application.InputBox("Select search range", _
       "Find Unique Values", Type:=8)
 Do
    Set ResultRng = Application.InputBox("Select results columnar range", _
       "Write Unique Values", Type:=8)
 Loop Until ResultRng.Columns.Count = 1

 iRow = 0
 For Each Cel In SearchRng
    If Application.WorksheetFunction.CountIf(ResultRng, Cel.Value) = 0 Then
       'This value doesn't already exist
       iRow = iRow + 1
       If iRow > ResultRng.Rows.Count Then
         MsgBox "Not enough rows in result range to write all unique values", _
         vbwarning, "Run terminated"
         Exit Sub
       Else
         ResultRng(iRow).Value = Cel.Value
       End If
    End If
 Next Cel

 'sort result range
 'ResultRng.Sort ResultRng

End Sub
4

1 回答 1

1

对于您的DATA!A1:A200示例更改

Set SearchRng = Application.InputBox("Select search range", _
   "Find Unique Values", Type:=8)

到

Set SearchRange = Sheets("DATA").Range("A1:A200")

编辑

说了这么多，你见过这个功能吗

Dim SearchRng As Range, ResultRng As Range
Set SearchRng = Sheets("DATA").Range("A1:A200")
Set ResultRng = Sheets("Results").Range("A2")
SearchRng.AdvancedFilter Action:= xlFilterCopy, CopyToRange:=ResultRng, Unique:=True
于 2012-11-05T15:26:40.753 回答