[ExcelVBA] 重複データの削除

>Blog Top Page >[ExcelVBA] Top Page >[ExcelVBA] プログラミング問題一覧

■お題
同一列内にあるデータで重複するものを削除せよ

■解答例
今回は、すごい簡単な問題を使って、ユーザフレンドリーなコードを書いてみます。
最終的なコードはこちら→最終的なコード

重複データを手動で削除する場合、ソートをかけて上から順に見て行き同じデータが並んでいる時削除するという手順を繰り返すことになると思います。
では、それをそのままコード化してみます。
モジュール名：SubModule内

Sub DelDuplicateRow(Col As Integer)
    If Not (0 < Col And Col < 257) Then
        MsgBox "列は1～256の間で指定して下さい"
        End
    End If
    
    Dim EndRow As Long
    EndRow = Cells(65536, Col).End(xlUp).Row
    
    Range(Cells(1, Col), Cells(EndRow, Col)).Sort Key1:=Cells(1, Col)
    
    Dim r As Long
    For r = 1 To EndRow - 1
        If Cells(r, Col) = Cells(r + 1, Col) Then Cells(r, Col) = ""
    Next
    
    Range(Cells(1, Col), Cells(EndRow, Col)).Sort Key1:=Cells(1, Col)
End Sub

１行目：列情報を数字で引数に受け取ります
２～５行目：列は1～256列までなのでそれ以外はエラーとしてメッセージを出して終了します
７行目：引数に指定された列の最終行を格納するための変数EndRowを宣言します。
セルは65536あるのでLong型ですね
８行目：最終行を取得します。
１０行目：ソートしています。
１２行目：For文で指定列のセルを最初から最終行に向かってループを
する時に行情報を格納する為の変数rを宣言します
１３行目：For文開始です。スタートは、１行目なので１。現在のセルと一つしたのセルを比較するので 　　　　終わりは、最終行目なのでEndRow - 1を指定してます
１４行目：現在のセルと一つ下のセルを比較して同じデータの時現在のセルを削除します
１５行目：繰り返し
１７行目：重複行は空になっているので間をつめるためにソートをかけます

モジュール名：SubModule内

Sub Main()
    Call DelDuplicateRow(1)
End Sub

A列目を指定するのであれば上記のように指定すればよいですね。



もっとも簡単なコードにして親切さのかけらもないコードが完成しました！


汎用性がなく使いづらいですね。
ここからユーザーフレンドリーなコードにかえていきましょう

---

Ｑ. 重複削除したいデータは、ある列の途中にあって最初が１行目最後が最終行だと困るのですが？
Ａ．引数にスタート行と終了行を用意しましょう。
モジュール名：SubModule内

Sub DelDuplicateRow(Col As Integer, StartRow As Long, EndRow As Long)
    If Not (0 < StartRow And StartRow < 65536) Then
        MsgBox "スタート行として、1から65535の間で指定して下さい"
        End
    End If
    
    If Not (1 < EndRow And EndRow < 65537) Then
        MsgBox "最終行として、2から65536の間で指定して下さい"
        End
    End If
    
    If EndRow < StartRow Then
        MsgBox "スタート行と最終行ではスタート行のほうが小さくなるように設定して下さい"
        End
    End If
    
    If Not (0 < Col And Col < 257) Then
        MsgBox "列は1～256の間で指定して下さい"
        End
    End If
    
    
    'EndRow = Cells(65536, Col).End(xlUp).Row
    Range(Cells(StartRow, Col), Cells(EndRow, Col)).Sort Key1:=Cells(StartRow, Col)
    
    Dim r As Long
    For r = StartRow To EndRow - 1
        If Cells(r, Col) = Cells(r + 1, Col) Then Cells(r, Col) = ""
    Next
    
    Range(Cells(StartRow, Col), Cells(EndRow, Col)).Sort Key1:=Cells(StartRow, Col)
End Sub

変更点は、
・引数にStartRow、EndRowを追加
・最終行を取得するのを廃止
・ソートの始まりのセル、For文のはじめの値をそれぞれStartRowに変更



これで決め細やかな設定ができるようになりました！
と、思って満足したらだめです。

---

Ｑ. 最初が１行目最後が最終行の決め打ちは困ると言ったけども毎回指定するなんてありえないです＞＜
Ａ．変数のオプション化をします。

こういう時に役立つのが変数のOptionalキーワードです。
引数に値がなければ、プログラムの方でデフォルトの値を決めるという方法です。
書き方は
Optional (受け渡し方法[ByVal])　変数名　(as 変数型[variant])　(=デフォルト値) (括弧)表示は、省略可能を現しており[四角括弧]は、省略時のデフォルト値です 一番最後のデフォルト値は定数でなければいけません。

モジュール名：SubModule内

Sub DelDuplicateRow(Col As Integer, Optional StartRow As Long = 1, Optional EndRow As Long)
    If EndRow = 0 Then EndRow = Cells(65536, Col).End(xlUp).Row
    
    If Not (0 < StartRow And StartRow < 65536) Then
        MsgBox "スタート行として、1から65535の間で指定して下さい"
        End
    End If
    
    If Not (1 < EndRow And EndRow < 65537) Then
        MsgBox "最終行として、2から65536の間で指定して下さい"
        End
    End If
    
    If EndRow < StartRow Then
        MsgBox "スタート行と最終行ではスタート行のほうが小さくなるように設定して下さい"
        End
    End If
    
    If Not (0 < Col And Col < 257) Then
        MsgBox "列は1～256の間で指定して下さい"
        End
    End If
    
    
    
    Range(Cells(StartRow, Col), Cells(EndRow, Col)).Sort Key1:=Cells(StartRow, Col)
    
    Dim r As Long
    For r = StartRow To EndRow - 1
        If Cells(r, Col) = Cells(r + 1, Col) Then Cells(r, Col) = ""
    Next
    
    Range(Cells(StartRow, Col), Cells(EndRow, Col)).Sort Key1:=Cells(StartRow, Col)
End Sub

変更点は、
・引数にのうちStarRowとEndRowをオプション化
・StartRowに値がない時は１を設定(Optionalキーワード内)
・EndRowは、設定がない時にEndメソッドで最終行を取得


利用する時は、こんな風になる。
モジュール名：SubModule内

Sub Main()
    'A列　最初～最終行を対象
    Call DelDuplicateRow(1)
    
    'B列　６行目～１１行目を対象
    Call DelDuplicateRow(2, 6, 11)
    
    'C列　６行目～最終行を対象
    Call DelDuplicateRow(3, 6)
    
    'D列　最初～１１行目を対象
    Call DelDuplicateRow(4, EndRow:=11)

End Sub

実行結果はこうなる

↑背景色が緑の部分が重複削除セル指定範囲


これで、必要な時に引数を追加すればよくなったので利用しやすさがぐんと上がりました。 これでおしまい！
なんて思いませんよね？

---

Ｑ.列名を数字に治すのがめんどいです。CI列って数字でいくつでしたっけ？＞＜
Ａ.ですよねぇ・・・。列名は文字列で指定しましょう。

やることは、一つ。
列名はA→Zまでいくとケタが繰り上がりAAとなるので26進数といえますね。
26進数を10進数に変換するコードをかくだけですね。


この関数は使い回しができそうですね。
モジュール名：CommonModule内

Function ColFromStrToNum(ColStr As String)
    Dim List() As Integer, i As Integer, position As Integer
    ReDim List(Len(ColStr) - 1)
    
    Dim Code As Integer
    position = 1
    For i = Len(ColStr) - 1 To 0 Step -1
        Code = Asc(UCase(Mid(ColStr, position, 1)))
        If Not (64 < Code And Code < 91) Then
            MsgBox "アルファベットを引数に渡して下さい"
            End
        Else
            List(i) = Code
        End If
        position = position + 1
    Next
    
    ColFromStrToNum = 0
    For i = 0 To UBound(List)
        ColFromStrToNum = ColFromStrToNum + (List(i) - 64) * 26 ^ i
    Next
End Function

１行目：列情報を受けとる引数を用意します。
２行目：List配列…列情報を１ケタずつ分解しキャラコードに変換した値を格納
i変数…For文でList配列のインデックスとして使用
position…列情報を１文字ずつに分解する際に使用
３行目：List配列の要素数を定義。文字列-1
５行目：Code…列情報を分解した文字をキャラコードに変換した値を格納
６行目：列情報を分解する際の文字位置を初期化する
７行目：列情報のキャラコードを１文字目を配列の最後から順に格納するため
For文の最初の数字を配列の最後の要素、最後を配列の最初の要素
Stepで-1を指定。26進数から10進数に計算する際に都合がよいため
８行目：列情報のうち一文字取り出し、大文字に変換し、キャラコードに変換する
９～１１行目：
アルファベット以外はエラーにする
１３行目：配列にキャラコードを代入
１５行目：列情報を１文字に切り出すための文字位置情報を１つ増やす
１６行目：繰り返し
１８行目：２６進数から１０進数へ変換する際の値を代入するまえに初期化する
１９～２１行目：
２６進数から１０進数へ変換する

モジュール名：SandModule内

Sub t1()
    Debug.Print ColFromStrToNum("a")
    Debug.Print ColFromStrToNum("z")
    Debug.Print ColFromStrToNum("IV")
    Debug.Print ColFromStrToNum("iv")
    Debug.Print "-----"
End Sub

Sub t2()
    Debug.Print ColFromStrToNum("1")
    Debug.Print "-----"
End Sub

テストしてみる。 t1関数の出力は

1 
 26 
 256 
 256 
-----

期待した値がでてますね。

t2関数の出力は「アルファベットを引数に渡して下さい」とでますね。
あとは、SubModule内のDelDuplicateRowの引数を文字列で受け取り変換するコードを追加すればおしまいですね。

以下に最終的なコードを示しておきます
モジュール名：SubModule

Option Explicit

Sub DelDuplicateRow(ColStr As String, Optional StartRow As Long = 1, Optional EndRow As Long)
    '### 同一列の重複データのセルを削除する関数
    '### 引数
    '###   省略不可：ColStr…列情報を文字列で指定 A～IV
    '###   省略可能：StartRow…最初の行を指定。省略した場合は１行目とする
    '###   省略可能：EndRow…最後の行を指定。省略した場合は、指定列の最終行
    '###
    '### ColFromStrToNum関数を必要
    '######################################################################

    Dim Col As Integer
    Col = ColFromStrToNum(ColStr)
    If EndRow = 0 Then EndRow = Cells(65536, Col).End(xlUp).Row
    
    
    If Not (0 < StartRow And StartRow < 65536) Then
        MsgBox "スタート行として、1から65535の間で指定して下さい"
        End
    End If
    
    If Not (1 < EndRow And EndRow < 65537) Then
        MsgBox "最終行として、2から65536の間で指定して下さい"
        End
    End If
    
    If EndRow < StartRow Then
        MsgBox "スタート行と最終行ではスタート行のほうが小さくなるように設定して下さい"
        End
    End If
    
    If Not (0 < Col And Col < 257) Then
        MsgBox "列は1～256の間で指定して下さい"
        End
    End If
    
    
    
    Range(Cells(StartRow, Col), Cells(EndRow, Col)).Sort Key1:=Cells(StartRow, Col)
    
    Dim r As Long
    For r = StartRow To EndRow - 1
        If Cells(r, Col) = Cells(r + 1, Col) Then Cells(r, Col) = ""
    Next
    
    Range(Cells(StartRow, Col), Cells(EndRow, Col)).Sort Key1:=Cells(StartRow, Col)
End Sub

モジュール名：CommonModule

Option Explicit

Function ColFromStrToNum(ColStr As String)
    '### 列情報　文字列→数字に変換する関数
    '### アルファベット以外を指定するとエラーとなる
    '##############################################
    
    Dim List() As Integer, i As Integer, position As Integer
    ReDim List(Len(ColStr) - 1)
    
    Dim Code As Integer
    position = 1
    For i = Len(ColStr) - 1 To 0 Step -1
        Code = Asc(UCase(Mid(ColStr, position, 1)))
        If Not (64 < Code And Code < 91) Then
            MsgBox "アルファベットを引数に渡し手下さい"
            End
        Else
            List(i) = Code
        End If
        position = position + 1
    Next
    
    ColFromStrToNum = 0
    For i = 0 To UBound(List)
        ColFromStrToNum = ColFromStrToNum + (List(i) - 64) * 26 ^ i
    Next
End Function

本当は、まだ手を加えたかったのですが別の機会とします。

>Blog Top Page >[ExcelVBA] Top Page >[ExcelVBA] プログラミング問題一覧