ユニークなExcel VBA

Question

私は右側に記載されている形式でUniqueを抽出します。私はフォーラムサイトの1つで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