[ExcelVBA] 重複データの削除２

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

■お題
複数列内(シートをまたぐ場合込み)にあるデータで重複するものを削除せよ

■解答例
複数列にまたぐ場合は、前回おこなったようなソートしてから上下を見比べて削除という方法には無理が限界が生じますね。なぜならば、複数列が可能になった瞬間から１列に収まらないセルの数の可能性がでてきますからねぇ。。
でも、かいちゃいますか。

重複データを削除する方法で一番単純なやり方は、連想配列に放りこむ方法です。連想配列とは、キーと値を１セットで管理する変数のことで重複チェックをしたい物をキーとし、値は適当な数値でもセットしておけば、同一の値に出くわしてもキー自体が増えることがないので、自動的に重複をはじけるわけです。
ただし、ひたすらメモリーに記憶しつづけていくので大量なデータを相手にする場合効率的ではないですね。
他の言語はさておき、少なくともExcelVBAに関しては効率が悪くなるのはあきらかです。


簡単な方法だとこれくらいしか思いつかないので、連想配列を使う方法でいきます。

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

view plainprint?

1. Option Explicit  
2.   
3. Sub DelDuplicateRow(ColInfo As Variant, Optional StartRow As Long = 1, Optional EndRow As Long, Optional multiple As Boolean = False, Optional SN As String)  
4.     '### 同一列の重複データのセルを削除する関数  
5.     '### 引数  
6.     '###   省略不可：ColInfo…列情報を数字(1～128)か文(A～IV)で指定  
7.     '###   省略可能：StartRow…最初の行を指定。省略した場合は１行目とする  
8.     '###   省略可能：EndRow…最後の行を指定。省略した場合は、指定列の最終行  
9.     '###   省略可能：Multiple…複数列を重複削除対象列とする場合Trueを指定  
10.     '###                       省略した場合は、False  
11.     '###   省略可能：SN…シート名を指定。省略時アクティブシート名  
12.     '###     
13.     '###   ColFromStrToNum関数を必要  
14.     '######################################################################  
15.     If SN = "" Then SN = ActiveSheet.Name  
16.       
17.     Dim Col As Integer  
18.     If IsNumeric(ColInfo) Then  
19.         Col = ColInfo  
20.     Else  
21.         Col = ColFromStrToNum(CStr(ColInfo))  
22.     End If  
23.   
24.     If EndRow = 0 Then EndRow = Sheets(SN).Cells(65536, Col).End(xlUp).Row  
25.       
26.       
27.     If Not (0 < StartRow And StartRow < 65536) Then  
28.         MsgBox "スタート行として、1から65535の間で指定して下さい"  
29.         End  
30.     End If  
31.       
32.     If Not (1 < EndRow And EndRow < 65537) Then  
33.         MsgBox "最終行として、2から65536の間で指定して下さい"  
34.         End  
35.     End If  
36.       
37.     If EndRow < StartRow Then  
38.         MsgBox "スタート行と最終行ではスタート行のほうが小さくなるように設定して下さい"  
39.         End  
40.     End If  
41.       
42.     If Not (0 < Col And Col < 257) Then  
43.         MsgBox "列は1～256の間で指定して下さい"  
44.         End  
45.     End If  
46.       
47.     Static hash As Object, Status As Boolean  
48.     If multiple Then  
49.         If Not Status Then  
50.             Set hash = CreateObject("Scripting.Dictionary")  
51.             Status = True  
52.         End If  
53.     Else  
54.         Set hash = CreateObject("Scripting.Dictionary")  
55.     End If  
56.       
57.       
58.       
59.     Dim r As Long  
60.     For r = StartRow To EndRow  
61.           
62.         If Not hash.Exists(CStr(Sheets(SN).Cells(r, Col))) Then  
63.             hash.Add CStr(Sheets(SN).Cells(r, Col)), 1  
64.         Else  
65.             Sheets(SN).Cells(r, Col) = ""  
66.         End If  
67.     Next  
68.       
69.     Sheets(SN).Range(Sheets(SN).Cells(StartRow, Col), Sheets(SN).Cells(EndRow, Col)).sort Key1:=Sheets(SN).Cells(StartRow, Col)  
70. End Sub  

Option Explicit

Sub DelDuplicateRow(ColInfo As Variant, Optional StartRow As Long = 1, Optional EndRow As Long, Optional multiple As Boolean = False, Optional SN As String)
    '### 同一列の重複データのセルを削除する関数
    '### 引数
    '###   省略不可：ColInfo…列情報を数字(1～128)か文(A～IV)で指定
    '###   省略可能：StartRow…最初の行を指定。省略した場合は１行目とする
    '###   省略可能：EndRow…最後の行を指定。省略した場合は、指定列の最終行
    '###   省略可能：Multiple…複数列を重複削除対象列とする場合Trueを指定
    '###                       省略した場合は、False
    '###   省略可能：SN…シート名を指定。省略時アクティブシート名
    '###   
    '###   ColFromStrToNum関数を必要
    '######################################################################
    If SN = "" Then SN = ActiveSheet.Name
    
    Dim Col As Integer
    If IsNumeric(ColInfo) Then
        Col = ColInfo
    Else
        Col = ColFromStrToNum(CStr(ColInfo))
    End If

    If EndRow = 0 Then EndRow = Sheets(SN).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
    
    Static hash As Object, Status As Boolean
    If multiple Then
        If Not Status Then
            Set hash = CreateObject("Scripting.Dictionary")
            Status = True
        End If
    Else
        Set hash = CreateObject("Scripting.Dictionary")
    End If
    
    
    
    Dim r As Long
    For r = StartRow To EndRow
        
        If Not hash.Exists(CStr(Sheets(SN).Cells(r, Col))) Then
            hash.Add CStr(Sheets(SN).Cells(r, Col)), 1
        Else
            Sheets(SN).Cells(r, Col) = ""
        End If
    Next
    
    Sheets(SN).Range(Sheets(SN).Cells(StartRow, Col), Sheets(SN).Cells(EndRow, Col)).sort Key1:=Sheets(SN).Cells(StartRow, Col)
End Sub

１行目：引数は、下記の通りです。
省略不可：ColInfo…列情報、数字 or 文字列どちらでも可
省略可能：StartRow…重複対象セルの開始行(省略時：１)
省略可能：EndRow…重複対象セルの終了行(省略時：指定列の最終行)
省略可能：Multiple…複数列を対象としたい時は True指定(省略時：False) 省略可能：SN…シート名を指定(省略時：アクティブシート名)

１５行目：SNが渡されなかった時は、アクティブシートの名前を指定
１７行目：Col…対象列を格納する変数
１８行目：引数のColInfoに入っている情報が数字かそうじゃないか判別。
１９行目：数字ならばColに代入
２１行目：数字でなければ、ColFromStrToNum関数に渡し何列目かに変換する
２４行目：引数のEndRowに値が渡されなければ最終行を取得し代入する

２７行目～４５行目までエラーチェック
４７行目：hash…重複判定に使う連想配列を宣言。
Staticステートメントで宣言することで、関数を抜けても値を保持しておく。
Statusオブジェクト宣言後に、Scripting.DictionaryをSetしたかどうかを判定する用の変数
Staticステートメントで宣言することで、関数を抜けても値を保持しておく ４８行目：MultipleがTrue(＝重複削除対象列が複数列)かどうか判別
４９行目：Scripting.DictionaryをセットしてあるかどうかStatus変数で判別
５０行目：Scripting.Dictionaryをセット(連想配列が使えるようになる)
５１行目：Statusをtrueにし、次回呼び出しの場合
５４行目：Scripting.Dictionaryをセットし、連想配列を使えるようにする
６０行目：For文で指定された列の最初のセルから最後のセルまでループしていきます
６２行目：連想配列に登録済みかどうかを判別します
６３行目：登録されてないときは、キーに追加します
６５行目：セル内容を削除します
６９行目：重複対象範囲をソートします ColFromStrToNum関数は、前回と一緒のままです。

モジュール名：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

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

---

以下使用例を示します。

view plainprint?

1. Sub t1()  
2.     Dim c As Integer  
3.     For c = 1 To 5  
4.         Call DelDuplicateRow3(c)  
5.     Next  
6. End Sub  

Sub t1()
    Dim c As Integer
    For c = 1 To 5
        Call DelDuplicateRow3(c)
    Next
End Sub

まずは、複数列を対象範囲にしなかった場合

それぞれの列で重複がはじかれます。 複数列のオプションを有効にすると…

view plainprint?

1. Sub t2()  
2.     Dim c As Integer  
3.     For c = 1 To 5  
4.         Call DelDuplicateRow3(c, multiple:=True)  
5.     Next  
6. End Sub  

Sub t2()
    Dim c As Integer
    For c = 1 To 5
        Call DelDuplicateRow3(c, multiple:=True)
    Next
End Sub

このように全体で重複セルを削除します。

>別シートも同じ容量でオプションの引数であるSNにシート名をセットすれば同様のことができます

ところで…Staticステートメントのスコープってプログラムが終了するまで値を保存ってなっているが終了っていつなんだろう？？少なくともマクロのリセットボタンを押すと値を捨ててくれるようだけどただプログラムの実行が完了しただけじゃ、値を捨てないみたい。。。 扱いが要注意だな。

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