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

VBA 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
タイトルとURLをコピーしました