VBA新しいセットから重複を削除する

Question

以下のコードは、新しいシートに新しいデータセットを作成しますが、重複していても要件に一致するすべてのものを取ります。新しいデータセットで重複をなくすためにコードを変更するにはどうすればよいですか？

Sub Testerss() 
 
    Dim c As Range, v As String, arr, x As Long, e 
 
    Dim d As Range 
 
    Dim ws As Worksheet 
 

 
    
 
    Set d = Worksheets("Sheet3").Range("D1") 
 

 
    For Each c In ActiveSheet.Range("D25:D105") 
 
     v = Trim(c.Value) 
 
     If Len(v) > 0 Then 
 

 
      v = Replace(v, vbLf, " ") 
 
      
 
      Do While InStr(v, " ") > 0 
 
       v = Replace(v, " ", " ") 
 
      Loop 
 

 
      
 
      arr = Split(v, " ") 
 
      For x = LBound(arr) To UBound(arr) 
 
       e = arr(x) 
 
       
 
       If Not IsError(Application.Match(LCase(e), Array("(bye)", "(hello)"), 0)) Then 
 
        If x > LBound(arr) Then 
 
         d.Value = arr(x - 1) & " " & e 
 
        Else 
 
         d.Value = "??? " & e 
 
        End If 
 
        Set d = d.Offset(1, 0) 
 
       End If 
 
      Next x 
 
     End If 
 
    Next c 
 
End Sub​

Answer 1

あなたは結果がすでにコピーされているかどうかを確認するためのチェックを追加することができます。まず、あなたが現在検討されている値がその範囲内にある場合

finalRow = Worksheets("Sheet3").Cells(1000000, 4).end(xlup).row 
Set resultRange = Worksheets("Sheet3").Range("D1:D" & finalRow) 

今すぐ見る結果の範囲を設定

duplicate = false 
for each result in resultRange 
    if v = result.Value then 
     duplicate = true 
     Exit For 
    end if 
next 

今もすべて一緒に

If Len(v) > 0 and not duplicate then 

を進める前に、重複をチェックします

Set d = Worksheets("Sheet3").Range("D1") 

For Each c In ActiveSheet.Range("D25:D105") 
    finalRow = Worksheets("Sheet3").Cells(1000000, 4).end(xlup).row 
    Set resultRange = Worksheets("Sheet3").Range("D1:D" & finalRow) 
    v = Trim(c.Value) 
    duplicate = false 
    for each result in resultRange 
     if v = result.Value then 
      duplicate = true 
      Exit For 
     end if 
    next 

    If Len(v) > 0 and not duplicate then 

    ...