从Excel中将唯一值填充到VBA数组中
任何人都可以给我VBA代码，将从Excel工作表中取出一个范围（行或列），并使用唯一值填充一个列表/数组，即：
table table chair table stool stool stool chair 当macros运行会创build一个数组有点像：
fur[0]=table fur[1]=chair fur[2]=stool
在这种情况下，我总是使用这样的代码（只要确保你select的分隔符不是search范围的一部分）
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, "|")
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
结合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
这是老派的做法。
它会比在单元格中循环更快（例如， For Each cell In Selection ），并且无论如何，只要您有一个矩形select（即不是Ctrl-select一堆随机单元格），它将会可靠。
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
老派的方法是我最喜欢的select。 谢谢。 而且确实很快。 但是我没有使用redim。 这里虽然是我真实世界的例子，我积累在列中find的每个唯一的“键”的值，并将其移动到一个数组（例如，一个员工和价值是每天工作小时）。 然后，我把每个键的最终值放在积极工作表上的总计区域。 我已经广泛地评论了任何想要在这里发生的事情的痛苦细节的人。 有限的错误检查由此代码完成。
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
还有一种方法
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
