Dim tmp As String
Dim arr() As String
If Not Selection Is Nothing Then
For Each cell In Selection
If (cell <> "") And (InStr(tmp, cell) = 0) Then
tmp = tmp & cell & "|"
End If
Next cell
End If
If Len(tmp) > 0 Then tmp = Left(tmp, Len(tmp) - 1)
arr = Split(tmp, "|")
0
Sub GetUniqueAndCount()
Dim d As Object, c As Range, k, tmp As String
Set d = CreateObject("scripting.dictionary")
For Each c In Selection
tmp = Trim(c.Value)
If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1
Next c
For Each k In d.keys
Debug.Print k, d(k)
Next k
End Sub
24
结合Tim的Dictionary方法和Jean_Francois下面的变体数组 .
你想要的数组在 objDict.keys
Sub A_Unique_B()
Dim X
Dim objDict As Object
Dim lngRow As Long
Set objDict = CreateObject("Scripting.Dictionary")
X = Application.Transpose(Range([a1], Cells(Rows.Count, "A").End(xlUp)))
For lngRow = 1 To UBound(X, 1)
objDict(X(lngRow)) = 1
Next
Range("B1:B" & objDict.Count) = Application.Transpose(objDict.keys)
End Sub
0
这是老派的做法 .
它将比循环遍历单元格（例如 For Each cell In Selection ）执行得更快，并且无论如何都是可靠的，只要你有一个矩形选择（即不选择Ctrl-选择一堆随机单元格） .
Sub FindUnique()
Dim varIn As Variant
Dim varUnique As Variant
Dim iInCol As Long
Dim iInRow As Long
Dim iUnique As Long
Dim nUnique As Long
Dim isUnique As Boolean
varIn = Selection
ReDim varUnique(1 To UBound(varIn, 1) * UBound(varIn, 2))
nUnique = 0
For iInRow = LBound(varIn, 1) To UBound(varIn, 1)
For iInCol = LBound(varIn, 2) To UBound(varIn, 2)
isUnique = True
For iUnique = 1 To nUnique
If varIn(iInRow, iInCol) = varUnique(iUnique) Then
isUnique = False
Exit For
End If
Next iUnique
If isUnique = True Then
nUnique = nUnique + 1
varUnique(nUnique) = varIn(iInRow, iInCol)
End If
Next iInCol
Next iInRow
'// varUnique now contains only the unique values.
'// Trim off the empty elements:
ReDim Preserve varUnique(1 To nUnique)
End Sub
Sub GetActualTotals()
'
' GetActualTotals Macro
'
' This macro accumulates values for each unique employee from the active
' spreadsheet.
'
' History
' October 2016 - Version 1
'
' Invocation
' I created a button labeled "Get Totals" on the Active Sheet that invokes
' this macro.
'
Dim ResourceName As String
Dim TotalHours As Double
Dim TotalPercent As Double
Dim IsUnique As Boolean
Dim FirstRow, LastRow, LastColumn, LastResource, nUnique As Long
Dim CurResource, CurrentRow, i, j As Integer
Dim Resource(1000, 2) As Variant
Dim Rng, r As Range
'
' INITIALIZATIONS
'
' These are index numbers for the Resource array
'
Const RName = 0
Const TotHours = 1
Const TotPercent = 2
'
' Set the maximum number of resources we'll
' process.
'
Const ResourceLimit = 1000
'
' We are counting on there being no unintended data
' in the spreadsheet.
'
' It won't matter if the cells are empty though. It just
' may take longer to run the macro.
' But if there is data where this macro does not expect it,
' assume unpredictable results.
'
' There are some hardcoded values used.
' This macro just happens to expect the names to be in Column C (or 3).
'
' Get the last row in the spreadsheet:
'
LastRow = Cells.Find(What:="*", _
After:=Range("C1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
'
' Furthermore, this macro banks on the first actual name to be in C6.
' so if the last row is row 65, the range we'll work with
' will evaluate to "C6:C65"
'
FirstRow = 6
Rng = "C" & FirstRow & ":C" & LastRow
Set r = Range(Rng)
'
' Initialize the resource array to be empty (even though we don't really
' need to but I'm old school).
'
For CurResource = 0 To ResourceLimit
Resource(CurResource, RName) = ""
Resource(CurResource, TotHours) = 0
Resource(CurResource, TotPercent) = 0
Next CurResource
'
' Start the resource counter at 0. The counter will represent the number of
' unique entries.
'
nUnique = 0
'
' LET'S GO
'
' Loop from the first relative row and the last relative row
' to process all the cells in the spreadsheet we are interested in
'
For i = 1 To LastRow - FirstRow
'
' Loop here for all unique entries. For any
' new unique entry, that array element will be
' initialized in the second if statement.
'
IsUnique = True
For j = 1 To nUnique
'
' If the current row element has a resource name and is already
' in the resource array, then accumulate the totals for that
' Resource Name. We then have to set IsUnique to false and
' exit the for loop to make sure we don't populate
' a new array element in the next if statement.
'
If r.Cells(i, 1).Value = Resource(j, RName) Then
IsUnique = False
Resource(j, TotHours) = Resource(j, TotHours) + _
r.Cells(i, 4).Value
Resource(j, TotPercent) = Resource(j, TotPercent) + _
r.Cells(i,5).Value
Exit For
End If
Next j
'
' If the resource name is unique then copy the initial
' values we find into the next resource array element.
' I ignore any null cells. (If the cell has a blank you might
' want to add a Trim to the cell). Not much error checking for
' the numerical values either.
'
If ((IsUnique) And (r.Cells(i, 1).Value <> "")) Then
nUnique = nUnique + 1
Resource(nUnique, RName) = r.Cells(i, 1).Value
Resource(nUnique, TotHours) = Resource(nUnique, TotHours) + _
r.Cells(i, 4).Value
Resource(nUnique, TotPercent) = Resource(nUnique, TotPercent) + _
r.Cells(i, 5).Value
End If
Next i
'
' Done processing all rows
'
' (For readability) Set the last resource counter to the last value of
' nUnique.
' Set the current row to the first relative row in the range (r=the range).
'
LastResource = nUnique
CurrentRow = 1
'
' Populate the destination cells with the accumulated values for
' each unique resource name.
'
For CurResource = 1 To LastResource
r.Cells(CurrentRow, 7).Value = Resource(CurResource, RName)
r.Cells(CurrentRow, 8).Value = Resource(CurResource, TotHours)
r.Cells(CurrentRow, 9).Value = Resource(CurResource, TotPercent)
CurrentRow = CurrentRow + 1
Next CurResource
End Sub
0
还有一个方法......
Sub get_unique()
Dim unique_string As String
lr = Sheets("data").Cells(Sheets("data").Rows.Count, 1).End(xlUp).Row
Set range1 = Sheets("data").Range("A2:A" & lr)
For Each cel In range1
If Not InStr(output, cel.Value) > 0 Then
unique_string = unique_string & cel.Value & ","
End If
Next
End Sub
11
下面的VBA脚本查找从单元格B5一直到B列中最后一个单元格的所有唯一值... $ B $ 1048576 . 一旦找到，它们就存储在数组中（objDict） .
Private Const SHT_MASTER = “MASTER”
Private Const SHT_INST_INDEX = “InstrumentIndex”
Sub UniqueList()
Dim Xyber
Dim objDict As Object
Dim lngRow As Long
Sheets(SHT_MASTER).Activate
Xyber = Application.Transpose(Sheets(SHT_MASTER).Range([b5], Cells(Rows.count, “B”).End(xlUp)))
Sheets(SHT_INST_INDEX).Activate
Set objDict = CreateObject(“Scripting.Dictionary”)
For lngRow = 1 To UBound(Xyber, 1)
If Len(Xyber(lngRow)) > 0 Then objDict(Xyber(lngRow)) = 1
Next
Sheets(SHT_INST_INDEX).Range(“B1:B” & objDict.count) = Application.Transpose(objDict.keys)
End Sub
7 回答
在这种情况下，我总是使用这样的代码（只需确保您选择的分隔符不是搜索范围的一部分）
结合Tim的Dictionary方法和Jean_Francois下面的变体数组 .
你想要的数组在
objDict.keys这是老派的做法 .
它将比循环遍历单元格（例如
For Each cell In Selection）执行得更快，并且无论如何都是可靠的，只要你有一个矩形选择（即不选择Ctrl-选择一堆随机单元格） .老派的方法是我最喜欢的选择 . 谢谢 . 它确实很快 . 但我没有使用redim . 这里虽然是我的真实世界的例子，我在列中找到每个唯一“密钥”的值，并将其移动到一个数组中（比如一个员工，值是每天工作的小时数） . 然后，我将每个键及其最终值放入活动工作表上的总计区域 . 我已经对那些想要了解这里发生的事情的痛苦细节的人进行了广泛的评论 . 此代码完成了有限的错误检查 .
还有一个方法......
下面的VBA脚本查找从单元格B5一直到B列中最后一个单元格的所有唯一值... $ B $ 1048576 . 一旦找到，它们就存储在数组中（objDict） .
我已经测试并记录了此解决方案的一些屏幕截图 . 这是你可以找到它的链接....
http://xybernetics.com/techtalk/excelvba-getarrayofuniquevaluesfromspecificcolumn/