Sub RemoveDuplicates()
Dim rng As Range
Dim cell As Range
Dim dict As Object
Dim key As Variant
'選択範囲を取得
Set rng = Selection
'辞書オブジェクトを作成
Set dict = CreateObject("Scripting.Dictionary")
'各セルをチェックして、重複している値を削除
For Each cell In rng
If Not dict.exists(cell.Value) Then
dict.Add cell.Value, 1
Else
cell.ClearContents
End If
Next cell
'メモリ解放
Set dict = Nothing
End Sub
上記のコードを実行するときに、
For文内の対象のセルが含まれている行のほかの列に
値が記入されていないときには、
その行を削除する、というように処理を変更したコードを
教えていただけないでしょうか？
もちろんです！
For文内の対象のセルが含まれている行の他の列に
値が記入されていない場合、
その行を削除するように処理を変更するには、
以下のようなコードに変更すると良いでしょう。
```vba
Sub RemoveDuplicates()
Dim rng As Range
Dim cell As Range
Dim dict As Object
Dim key As Variant
Dim ws As Worksheet
Dim rowIndex As Long
' 選択範囲を取得
Set rng = Selection
' 辞書オブジェクトを作成
Set dict = CreateObject("Scripting.Dictionary")
' 対象のシートを取得
Set ws = rng.Worksheet
' 各セルをチェックして、重複している値を削除
For Each cell In rng
If Not dict.exists(cell.Value) Then
dict.Add cell.Value, 1
Else
cell.ClearContents
End If
Next cell
' 対象の行を逆順でチェックし、空白行を削除
For rowIndex = rng.Rows.Count To 1 Step -1
If Application.WorksheetFunction.CountA(
ws.Rows(rng.Cells(rowIndex, 1).Row)) = 0 Then
ws.Rows(rng.Cells(rowIndex, 1).Row).Delete
End If
Next rowIndex
' メモリ解放
Set dict = Nothing
End Sub
```
このコードでは、
重複値を削除した後、対象の範囲内の行を逆順でチェックし、
行全体が空白の場合にその行を削除します。
このようにすることで、
元の範囲内に空白の行が含まれないように
することができます。
お試しください！
コメント
コメントを投稿