從列中獲取唯一值

Question

手頭的任務是在 A 列中搜索以查看我有哪些值（它們以字母的形式）並為每個唯一條目粘貼，其值在另一列中一次。

這是一個視覺解釋：

我想出的是創建一個 For 循環，該循環通過列 A 進行迭代，並創建一個條件，如果它找到某個值，那么它將在該范圍內插入該值。 這是代碼：

For i = 1 to 26

if cells(i,26).value= "A" Then

Range ("C1")= "A"

Elseif cells(i,26).value = "B" then
Range ("C2").value = "B"
ElseIf (i,26).value = "C" then 
Range ("C3").value = "C"
EndIf
Next i
end sub 

我想縮短這個過程，因為我的數據集非常大，有很多公司名稱。 有什么建議嗎？ 我相信必須有一種方法來了解這些價值觀，而不必自己查看所有價值觀。

Answer 1

如果目標只是獲取在Column A Column C列中找到的唯一值列表，則可以使用以下宏。 這實際上只是重新創建您手動查找唯一值的一種方法的步驟。 不是最復雜的解決方案，但它有效

1. 使用公司名稱創建列的副本（使用工作表中的最后一個可用列）
2. 對輔助列進行重復數據刪除
3. 將去重列復制到目標
4. 刪除輔助列

假設未使用工作表上的最后一列

---

Sub Unique()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim lr As Long, lc As Long

'Determine Range Size
lr = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
lc = ws.Cells(1, ws.Columns.Count).Column

'Copy Company Names To Helper Column/Remove Duplicates
ws.Range("A2:A" & lr).Copy ws.Cells(1, lc)
ws.Columns(lc).RemoveDuplicates Columns:=1, Header:=xlNo
lr = ws.Cells(ws.Rows.Count, lc).End(xlUp).Row

'Output Unique Values From Helper Column
ws.Range(ws.Cells(1, lc), ws.Cells(lr, lc)).Copy
ws.Range("C2").PasteSpecial xlPasteValues

'Delete Helper Column
ws.Columns(lc).Delete

End Sub

---

注意我對帖子的評論。 VBA 這里可能根本不需要

Answer 2

這是使用.RemoveDuplicates的一個稍微不同的版本，它也會刪除空白單元格。

您也可以在沒有 VBA 的情況下執行此操作。 只需將所需的列復制到另一個列，然后使用“數據”選項卡下的“刪除重復項”。

Sub Unique_Values()

   Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
   
    'Getting all the values in column A (except header)
    'Copying them into cell C2 and below
    ws.Range("A2", Range("A1048576").End(xlUp)).Copy Range("C2")
    
    'setting the header for the column C
    ws.Range("C1").Value = "What companies are in Column A?"
    
    'Removing duplicates and blanks from column C
    With ws.Range("$C$2", Range("C1048576").End(xlUp))
        .Value = .Value
        .RemoveDuplicates Columns:=1, Header:=xlNo
        On Error Resume Next
        .SpecialCells(xlCellTypeBlanks).Delete xlShiftUp
       On Error GoTo 0
    End With

End Sub

盡管我同意另一個答案中使用的編碼約定，但我認為這會使問題過於復雜，這會使初學者感到困惑。

Answer 3

我認為到目前為止，這兩個答案都會給你你想要的，也許可以進一步簡化？

Sub GetUniqueQuick()
Dim LastRow As Long
Application.ScreenUpdating = False  
LastRow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

Sheets("Sheet1").Range("A2:A" & LastRow).Copy Sheets("Sheet1").Range("C2")    
Sheets("Sheet1").Range("C1:C" & LastRow).RemoveDuplicates Columns:=1, Header:=xlYes

End Sub

Answer 4

使用 MS 365 的動態功能，您可以簡單地在給定范圍內應用工作表 function UNIQUE() ，例如

= UNIQUE(A2:A100)

或將其集成到用戶定義的 function

Function GetCompanies(rng As Range)
    If rng.Columns.Count > 1 Then Exit Function    ' allow only one column
    GetCompanies = Application.Unique(rng)         ' return function result as 2-dim array
End Function

由於空單元格會導致具有0 output 的偽唯一性，因此您可以在公式中調用它們並添加裝飾性空白字符串：

=GetCompanies(A2:A100)&""