[ExcelVBA] 重複データの削除

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

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

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

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

view plainprint?

1. Sub DelDuplicateRow(Col As Integer)  
2.     If Not (0 < Col And Col < 257) Then  
3.         MsgBox "列は1～256の間で指定して下さい"  
4.         End  
5.     End If  
6.       
7.     Dim EndRow As Long  
8.     EndRow = Cells(65536, Col).End(xlUp).Row  
9.       
10.     Range(Cells(1, Col), Cells(EndRow, Col)).Sort Key1:=Cells(1, Col)  
11.       
12.     Dim r As Long  
13.     For r = 1 To EndRow - 1  
14.         If Cells(r, Col) = Cells(r + 1, Col) Then Cells(r, Col) = ""  
15.     Next  
16.       
17.     Range(Cells(1, Col), Cells(EndRow, Col)).Sort Key1:=Cells(1, Col)  
18. End Sub  

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内

view plainprint?

1. Sub Main()  
2.     Call DelDuplicateRow(1)  
3. End Sub  

Sub Main()
    Call DelDuplicateRow(1)
End Sub

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



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


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

---

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

view plainprint?

1. Sub DelDuplicateRow(Col As Integer, StartRow As Long, EndRow As Long)  
2.     If Not (0 < StartRow And StartRow < 65536) Then  
3.         MsgBox "スタート行として、1から65535の間で指定して下さい"  
4.         End  
5.     End If  
6.       
7.     If Not (1 < EndRow And EndRow < 65537) Then  
8.         MsgBox "最終行として、2から65536の間で指定して下さい"  
9.         End  
10.     End If  
11.       
12.     If EndRow < StartRow Then  
13.         MsgBox "スタート行と最終行ではスタート行のほうが小さくなるように設定して下さい"  
14.         End  
15.     End If  
16.       
17.     If Not (0 < Col And Col < 257) Then  
18.         MsgBox "列は1～256の間で指定して下さい"  
19.         End  
20.     End If  
21.       
22.       
23.     'EndRow = Cells(65536, Col).End(xlUp).Row  
24.     Range(Cells(StartRow, Col), Cells(EndRow, Col)).Sort Key1:=Cells(StartRow, Col)  
25.       
26.     Dim r As Long  
27.     For r = StartRow To EndRow - 1  
28.         If Cells(r, Col) = Cells(r + 1, Col) Then Cells(r, Col) = ""  
29.     Next  
30.       
31.     Range(Cells(StartRow, Col), Cells(EndRow, Col)).Sort Key1:=Cells(StartRow, Col)  
32. End Sub  

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内

view plainprint?

1. Sub DelDuplicateRow(Col As Integer, Optional StartRow As Long = 1, Optional EndRow As Long)  
2.     If EndRow = 0 Then EndRow = Cells(65536, Col).End(xlUp).Row  
3.       
4.     If Not (0 < StartRow And StartRow < 65536) Then  
5.         MsgBox "スタート行として、1から65535の間で指定して下さい"  
6.         End  
7.     End If  
8.       
9.     If Not (1 < EndRow And EndRow < 65537) Then  
10.         MsgBox "最終行として、2から65536の間で指定して下さい"  
11.         End  
12.     End If  
13.       
14.     If EndRow < StartRow Then  
15.         MsgBox "スタート行と最終行ではスタート行のほうが小さくなるように設定して下さい"  
16.         End  
17.     End If  
18.       
19.     If Not (0 < Col And Col < 257) Then  
20.         MsgBox "列は1～256の間で指定して下さい"  
21.         End  
22.     End If  
23.       
24.       
25.       
26.     Range(Cells(StartRow, Col), Cells(EndRow, Col)).Sort Key1:=Cells(StartRow, Col)  
27.       
28.     Dim r As Long  
29.     For r = StartRow To EndRow - 1  
30.         If Cells(r, Col) = Cells(r + 1, Col) Then Cells(r, Col) = ""  
31.     Next  
32.       
33.     Range(Cells(StartRow, Col), Cells(EndRow, Col)).Sort Key1:=Cells(StartRow, Col)  
34. End Sub  

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内

view plainprint?

1. Sub Main()  
2.     'A列　最初～最終行を対象  
3.     Call DelDuplicateRow(1)  
4.       
5.     'B列　６行目～１１行目を対象  
6.     Call DelDuplicateRow(2, 6, 11)  
7.       
8.     'C列　６行目～最終行を対象  
9.     Call DelDuplicateRow(3, 6)  
10.       
11.     'D列　最初～１１行目を対象  
12.     Call DelDuplicateRow(4, EndRow:=11)  
13.   
14. End Sub  

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内

view plainprint?

1. Function ColFromStrToNum(ColStr As String)  
2.     Dim List() As Integer, i As Integer, position As Integer  
3.     ReDim List(Len(ColStr) - 1)  
4.       
5.     Dim Code As Integer  
6.     position = 1  
7.     For i = Len(ColStr) - 1 To 0 Step -1  
8.         Code = Asc(UCase(Mid(ColStr, position, 1)))  
9.         If Not (64 < Code And Code < 91) Then  
10.             MsgBox "アルファベットを引数に渡して下さい"  
11.             End  
12.         Else  
13.             List(i) = Code  
14.         End If  
15.         position = position + 1  
16.     Next  
17.       
18.     ColFromStrToNum = 0  
19.     For i = 0 To UBound(List)  
20.         ColFromStrToNum = ColFromStrToNum + (List(i) - 64) * 26 ^ i  
21.     Next  
22. End Function  

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内

view plainprint?

1. Sub t1()  
2.     Debug.Print ColFromStrToNum("a")  
3.     Debug.Print ColFromStrToNum("z")  
4.     Debug.Print ColFromStrToNum("IV")  
5.     Debug.Print ColFromStrToNum("iv")  
6.     Debug.Print "-----"  
7. End Sub  
8.   
9. Sub t2()  
10.     Debug.Print ColFromStrToNum("1")  
11.     Debug.Print "-----"  
12. End Sub  

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関数の出力は

view plainprint?

1. 1   
2.  26   
3.  256   
4.  256   
5. -----  

1 
 26 
 256 
 256 
-----

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

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

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

view plainprint?

1. Option Explicit  
2.   
3. Sub DelDuplicateRow(ColStr As String, Optional StartRow As Long = 1, Optional EndRow As Long)  
4.     '### 同一列の重複データのセルを削除する関数  
5.     '### 引数  
6.     '###   省略不可：ColStr…列情報を文字列で指定 A～IV  
7.     '###   省略可能：StartRow…最初の行を指定。省略した場合は１行目とする  
8.     '###   省略可能：EndRow…最後の行を指定。省略した場合は、指定列の最終行  
9.     '###  
10.     '### ColFromStrToNum関数を必要  
11.     '######################################################################  
12.   
13.     Dim Col As Integer  
14.     Col = ColFromStrToNum(ColStr)  
15.     If EndRow = 0 Then EndRow = Cells(65536, Col).End(xlUp).Row  
16.       
17.       
18.     If Not (0 < StartRow And StartRow < 65536) Then  
19.         MsgBox "スタート行として、1から65535の間で指定して下さい"  
20.         End  
21.     End If  
22.       
23.     If Not (1 < EndRow And EndRow < 65537) Then  
24.         MsgBox "最終行として、2から65536の間で指定して下さい"  
25.         End  
26.     End If  
27.       
28.     If EndRow < StartRow Then  
29.         MsgBox "スタート行と最終行ではスタート行のほうが小さくなるように設定して下さい"  
30.         End  
31.     End If  
32.       
33.     If Not (0 < Col And Col < 257) Then  
34.         MsgBox "列は1～256の間で指定して下さい"  
35.         End  
36.     End If  
37.       
38.       
39.       
40.     Range(Cells(StartRow, Col), Cells(EndRow, Col)).Sort Key1:=Cells(StartRow, Col)  
41.       
42.     Dim r As Long  
43.     For r = StartRow To EndRow - 1  
44.         If Cells(r, Col) = Cells(r + 1, Col) Then Cells(r, Col) = ""  
45.     Next  
46.       
47.     Range(Cells(StartRow, Col), Cells(EndRow, Col)).Sort Key1:=Cells(StartRow, Col)  
48. End Sub  

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

view plainprint?

1. Option Explicit  
2.   
3. Function ColFromStrToNum(ColStr As String)  
4.     '### 列情報　文字列→数字に変換する関数  
5.     '### アルファベット以外を指定するとエラーとなる  
6.     '##############################################  
7.       
8.     Dim List() As Integer, i As Integer, position As Integer  
9.     ReDim List(Len(ColStr) - 1)  
10.       
11.     Dim Code As Integer  
12.     position = 1  
13.     For i = Len(ColStr) - 1 To 0 Step -1  
14.         Code = Asc(UCase(Mid(ColStr, position, 1)))  
15.         If Not (64 < Code And Code < 91) Then  
16.             MsgBox "アルファベットを引数に渡し手下さい"  
17.             End  
18.         Else  
19.             List(i) = Code  
20.         End If  
21.         position = position + 1  
22.     Next  
23.       
24.     ColFromStrToNum = 0  
25.     For i = 0 To UBound(List)  
26.         ColFromStrToNum = ColFromStrToNum + (List(i) - 64) * 26 ^ i  
27.     Next  
28. End Function  

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] プログラミング問題一覧