重複したレコードを削除する

日ごろ、スクリプトを書くことがないので、
書いてみるとなかなか楽しい。

重複項目を削除したい列の先頭にカーソルを合わせてDoDeleteSynonim()を呼び出せば、重複項目が行ごと消える仕組み。
しかしながら、Find関数の使い方が悪いみたいで、列の限定検索ができていない。
再利用する場合は注意が必要。

Sub DoDeleteSynonim()
    If TypeName(Selection) <> "Range" Then Exit Sub
    If Selection.Worksheet.Name = "configure" Then Exit Sub
    Call DeleteSynonim(Selection)
    Call DoDeleteTargetsByConfigure(Selection, "configure")
End Sub


Function GetCurrentCell(ByRef cell As Range) As Range
    Set GetCurrentCell = cell.cells(1, 1)
End Function

' 重複削除 
Sub DeleteSynonim(ByRef cell As Range)
    Dim cellsCurrent As Range
    Dim cellsTarget As Range
    
    Set cellsCurrent = GetCurrentCell(cell)
    Do
        Dim data As Object
        Set data = cellsCurrent.Parent.cells.Find(What:=cellsCurrent.Value, After:=cellsCurrent, LookIn _
            :=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection _
            :=xlNext, MatchCase:=False, MatchByte:=False, SearchFormat:=False)
        Set cellsTarget = cellsCurrent.Parent.cells(data.Row, data.Column)
        If cellsCurrent.Row = cellsTarget.Row Then
            Set cellsCurrent = cellsCurrent.Offset(1, 0)
        Else
            cellsTarget.Parent.Rows(cellsTarget.Row).Delete
        End If
    Loop While cellsCurrent.Value <> ""
        
End Sub

' sheetname のシートのA列にある項目を探し出して削除する 
Sub DoDeleteTargetsByConfigure(ByRef target As Range, ByVal sheetname As String)
    Dim wb As Workbook
    Dim ConfigureSheet As Worksheet
    Dim targetSheet As Worksheet
    Set targetSheet = target.Worksheet
    Set wb = targetSheet.Parent
    ' 対象シートの見つけ出し
    Set ConfigureSheet = wb.Sheets(sheetname)
    If ConfigureSheet Is Nothing Then Exit Sub
    Dim checkcell As Range
    Set checkcell = ConfigureSheet.Range("A1")
    
    If checkcell.Value = "" Then Exit Sub
    Dim cellsCurrent As Range
    Dim cellsTarget As Range
    Set cellsCurrent = GetCurrentCell(target)
    
    ' 現在選択中の行が消えることがあるので、座標を保持する
    Dim currentAddress As String
    currentAddress = cellsCurrent.Address
    
    Do
        Set cellsCurrent = targetSheet.Range(currentAddress)
        Dim data As Object
        Set data = cellsCurrent.Parent.cells.Find(What:=checkcell.Value, After:=cellsCurrent, LookIn _
            :=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection _
            :=xlNext, MatchCase:=False, MatchByte:=False, SearchFormat:=False)
        If data Is Nothing Then
            Set checkcell = checkcell.Offset(1, 0)
        Else
            Set cellsTarget = cellsCurrent.Parent.cells(data.Row, data.Column)
            cellsTarget.Parent.Rows(cellsTarget.Row).Delete
        End If
    Loop While checkcell.Value <> ""
End Sub