使用 VBA 在 excel 中创建列表/数组以获取列中唯一名称的列表
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/22004091/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Creating a list/array in excel using VBA to get a list of unique names in a column
提问by Ryflex
I'm trying to create a list of unique names in a column but I've never understood how to use ReDimcorrectly, could someone help finish this off for me and explain how it's done or better suggest an alternative better/faster way.
我正在尝试在列中创建一个唯一名称列表，但我从来没有理解如何ReDim正确使用，有人可以帮我完成它并解释它是如何完成的，或者更好地建议一种更好/更快的替代方法。
Sub test()
LastRow = Range("C65536").End(xlUp).Row
For Each Cell In Range("C4:C" & LastRow)
OldVar = NewVar
NewVar = Cell
If OldVar <> NewVar Then
`x =...
End If
Next Cell
End Sub
My Data is in the format of:
我的数据格式如下：
Stack
Stack
Stack
Stack
Stack
Overflow
Overflow
Overflow
Overflow
Overflow
Overflow
Overflow
Overflow
.com
.com
.com
So essentially once it has the name once it will never popup again later on down in the list.
所以基本上一旦它有了名字，它就永远不会在列表中稍后再次弹出。
At the end the array should consist of:
最后，数组应包括：
Stack
Overflow
.com
回答by Doug Glancy
You don't need arrays for this. Try something like:
您不需要为此使用数组。尝试类似：
ActiveSheet.Range("$A:$A$" & LastRow).RemoveDuplicates Columns:=1, Header:=xlYes
If there's no header, change accordingly.
如果没有标题，请相应更改。
EDIT: Here's the traditional method, which takes advantage of the fact that each item in a Collectionmust have a unique key:
编辑：这是传统方法，它利用了一个事实，即 a 中的每个项目都Collection必须有一个唯一的键：
Sub test()
Dim ws As Excel.Worksheet
Dim LastRow As Long
Dim coll As Collection
Dim cell As Excel.Range
Dim arr() As String
Dim i As Long
Set ws = ActiveSheet
With ws
LastRow = .Range("C" & .Rows.Count).End(xlUp).Row
Set coll = New Collection
For Each cell In .Range("C4:C" & LastRow)
On Error Resume Next
coll.Add cell.Value, CStr(cell.Value)
On Error GoTo 0
Next cell
ReDim arr(1 To coll.Count)
For i = LBound(arr) To UBound(arr)
arr(i) = coll(i)
'to show in Immediate Window
Debug.Print arr(i)
Next i
End With
End Sub
回答by L42
You can try my suggestion for a work around in Doug's approach.
But if you want to stick with your logic though, you can try this:
您可以尝试我的建议，以解决 Doug 的方法。
但是如果你想坚持你的逻辑，你可以试试这个：
Option Explicit
Sub GetUnique()
Dim rng As Range
Dim myarray, myunique
Dim i As Integer
ReDim myunique(1)
With ThisWorkbook.Sheets("Sheet1")
Set rng = .Range(.Range("A1"), .Range("A" & .Rows.Count).End(xlUp))
myarray = Application.Transpose(rng)
For i = LBound(myarray) To UBound(myarray)
If IsError(Application.Match(myarray(i), myunique, 0)) Then
myunique(UBound(myunique)) = myarray(i)
ReDim Preserve myunique(UBound(myunique) + 1)
End If
Next
End With
For i = LBound(myunique) To UBound(myunique)
Debug.Print myunique(i)
Next
End Sub
This uses array instead of range.
It also uses Matchfunction instead of a nested For Loop.
I didn't have the time to check the time difference though.
So I leave the testing to you.
这使用数组而不是范围。
它还使用Match函数而不是嵌套的For Loop.
虽然我没有时间检查时差。
所以我把测试留给你。
回答by some guy
FWIW, here's the dictionary thing. After setting a reference to MS Scripting. You can Hyman around with the array size of avInput to match your needs.
FWIW，这是字典的东西。设置对 MS Scripting 的引用后。您可以调整 avInput 的数组大小以满足您的需要。
Sub somemacro()
Dim avInput As Variant
Dim uvals As Dictionary
Dim i As Integer
Dim rop As Range
avInput = Sheets("data").UsedRange
Set uvals = New Dictionary
For i = 1 To UBound(avInput, 1)
If uvals.Exists(avInput(i, 1)) = False Then
uvals.Add avInput(i, 1), 1
Else
uvals.Item(avInput(i, 1)) = uvals.Item(avInput(i, 1)) + 1
End If
Next i
ReDim avInput(1 To uvals.Count)
i = 1
For Each kv In uvals.Keys
avInput(i) = kv
i = i + 1
Next kv
Set rop = Sheets("sheet2").Range("a1")
rop.Resize(UBound(avInput, 1), 1) = Application.Transpose(avInput)
End Sub
回答by Jochen H. W.
Inspired by VB.Net Generics List(Of Integer), I created my own module for that. Maybe you find it useful, too or you'd like to extend for additional methods e.g. to remove items again:
受 VB.Net 泛型列表（整数）的启发，我为此创建了自己的模块。也许您也发现它很有用，或者您想扩展其他方法，例如再次删除项目：
'Save module with name: ListOfInteger
Public Function ListLength(list() As Integer) As Integer
On Error Resume Next
ListLength = UBound(list) + 1
On Error GoTo 0
End Function
Public Sub ListAdd(list() As Integer, newValue As Integer)
ReDim Preserve list(ListLength(list))
list(UBound(list)) = newValue
End Sub
Public Function ListContains(list() As Integer, value As Integer) As Boolean
ListContains = False
Dim MyCounter As Integer
For MyCounter = 0 To ListLength(list) - 1
If list(MyCounter) = value Then
ListContains = True
Exit For
End If
Next
End Function
Public Sub DebugOutputList(list() As Integer)
Dim MyCounter As Integer
For MyCounter = 0 To ListLength(list) - 1
Debug.Print list(MyCounter)
Next
End Sub
You might use it as follows in your code:
您可以在代码中按如下方式使用它：
Public Sub IntegerListDemo_RowsOfAllSelectedCells()
Dim rows() As Integer
Set SelectedCellRange = Excel.Selection
For Each MyCell In SelectedCellRange
If IsEmpty(MyCell.value) = False Then
If ListOfInteger.ListContains(rows, MyCell.Row) = False Then
ListAdd rows, MyCell.Row
End If
End If
Next
ListOfInteger.DebugOutputList rows
End Sub
If you need another list type, just copy the module, save it at e.g. ListOfLong and replace all types Integer by Long. That's it :-)
如果您需要其他列表类型，只需复制模块，将其保存在例如 ListOfLong 中，然后将所有类型 Integer 替换为 Long。就是这样 ：-）
回答by RollTideMike
I realize this is an old question, but I use a much simpler way. Typically I just grab the list that I need, either by query or copying an existing list or whatever, then remove the duplicates. We will assume for this answer that your list is already in column C, row 4, as per the original question. This method works for whatever size list you have and you can select header yes or no.
我意识到这是一个老问题，但我使用了一种更简单的方法。通常我只是通过查询或复制现有列表或其他方式获取我需要的列表，然后删除重复项。对于此答案，我们将假设您的列表已根据原始问题位于 C 列第 4 行。此方法适用于您拥有的任何大小列表，您可以选择标题是或否。
Dim rng as range
Range("C4").Select
Set rng = Range(Selection, Selection.End(xlDown))
rng.RemoveDuplicates Columns:=1, Header:=xlYes
