填充唯一值到從Excel

Question

一個VBA陣列誰能給我VBA代碼，將從Excel片採取的範圍（行或列）和填充列表/陣列與所述唯一值， 即：

table 
table 
chair 
table 
stool 
stool 
stool 
chair 

當宏運行將創建一個數組一些事情，如：

fur[0]=table 
fur[1]=chair 
fur[2]=stool 

Answer 1

在這種情況下我總是用這樣的代碼（只需確保定界符您選擇不在搜索範圍的一部分）

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, "|") 

Answer 2

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 

Answer 3

這是老派的做法。

它會比循環遍歷單元更快地執行（例如，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 

Answer 4

將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 

Answer 5

老學校的方法是我最喜歡的選擇。謝謝。這確實很快。但我沒有使用redim。這裏雖然是我真實世界的例子，我爲一列中找到的每個唯一「關鍵字」積累值並將其移入數組（例如，對於員工而言，值是每天工作的小時數）。然後，我將每個鍵的最終值放入活動工作表的總計區域。對於那些想要對這裏發生的事情進行痛苦細節的人，我已經廣泛地發表了評論。有限的錯誤檢查由此代碼完成。

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 

Answer 6

另一種方式......

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