【VBA】特定の列で重複している値を排除して一意の値を別のシートに記載してみた

エクセルのマクロを利用して、特定の列で重複している値を排除して別のシートに記載してみました。

特定の列で重複している値を排除して別のシートに記載する

やりたいことは以下の画像のように、特定の列で重複している値がある場合に、その列から重複している値を排除して、つまり一意の値を取り出して別のシートに記載する、というものです。

画像ではA列を対象として重複を調べ、一意の値を [NewSheet] というシートのA列に記載しています。
黄色塗りとなっているセルが重複の値です。

・重複した値の列があるシート

・一意の値のみを別のシートに記載

以下のvbaで実行可能です。

Sub FindUniqueValues()
    Dim sourceSheet As Worksheet
    Dim uniqueSheet As Worksheet
    Dim sourceRange As Range
    Dim cell As Range
    Dim uniqueValues As New Collection
    Dim value As Variant
    
    ' 操作するシートと範囲を設定
    Set sourceSheet = ThisWorkbook.Sheets("Sheet1")
    Set sourceRange = sourceSheet.Range("A1:A" & sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row)
    
    ' 一意な値を取得
    On Error Resume Next
    For Each cell In sourceRange
        If cell.value <> "" Then
            uniqueValues.Add cell.value, CStr(cell.value)
        End If
    Next cell
    On Error GoTo 0
    
    ' 新しいシートを作成もしくは既存で同じ名前のシートがある場合はクリア
    On Error Resume Next
    Set uniqueSheet = ThisWorkbook.Sheets("UniqueValues")
    On Error GoTo 0
    
    If uniqueSheet Is Nothing Then
        Set uniqueSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        uniqueSheet.Name = "NewSheet"
    Else
        uniqueSheet.Cells.Clear
    End If
    
    ' 一意な値を新しいシートに書き込む
    For Each value In uniqueValues
        uniqueSheet.Cells(uniqueSheet.Cells(uniqueSheet.Rows.Count, "A").End(xlUp).Row + 1, "A").value = value
    Next value
    
End Sub