Excel VBA的唯一性

Question

我希望以右侧给出的格式提取“唯一”。 我在论坛站点之一上找到了VBA代码，但此代码不适合我。 有没有办法修改代码或编写更好的东西。 我确实有一个公式，但是公式相当耗费资源，并且很大的excel加载速度非常慢。

Sub FindDistinctValues()
Dim LastRowFrom As Long
Dim LastRowTo As Long
Dim i As Long, j As Long
Dim temp As Integer
Dim found As Boolean
'determines the last row that contains data in column A
LastRowFrom = Range("A" & Rows.Count).End(xlUp).Row
'Loop for each entry in column A
For i = 2 To LastRowFrom
'get the next value from column A
temp = Range("A" & i).Value

'Determine the last row with data in column B
LastRowTo = Range("B" & Rows.Count).End(xlUp).Row

'initialize j and found
j = 1
 found = False

     'Loop through "To List" until a match is found or the list has been    searched
      Do
      'check if the value exists in B column
      If temp = Range("B" & j).Value Then
     found = True
     End If
     'increment j
    j = j + 1
     Loop Until found Or j = LastRowTo + 1

    'if the value is not already in column B
    If Not found Then
   Range("B" & j).Value = temp
  End If
Next i
End Sub

http://image.prntscr.com/image/6bea7bb438ef4678a50cec6bebc78589.png

Answer 1

我没有测试，但是类似这样：

Sub FindDistinctValues()
    Dim dict As Object, cell As Range
    Set dict = CreateObject("Scripting.Dictionary")

    For Each cell in Range("A1").CurrentRegion.Resize(, 1)
        If Not dict.Exists(cell & "")
            cell(, 2) = "Unique"
            dict.Add cell & "", 0
        End If
    Next
End Sub