第9回 直感！スグに使える業務向けVBA汎用プロシージャ(重複・ユニーク抽出)

第0回で配布しました汎用プロシージャのコードの紹介と簡単な解説をやっていきたいと思います！
以下のリンクから .bas ファイルをダウンロードできます（zipファイル）

https://drive.google.com/file/d/11qEUTsq87UItzoKu2okX5WgEopRercCb/view?usp=drive_link

今回ご紹介するプロシージャは
| プロシージャ名		| 概要						|
|-------------------------------|-----------------------------------------------|
| GetUniqueValues     | セル範囲内のユニークな値だけを抽出		|
| GetDuplicateValues  | セル範囲内の重複値だけを抽出	|

これらはVBAの書籍や記事でも出てくる内容ですね！定番でもありDXにおいてかなり重要度が高くまた応用範囲の広い分野となっております。

個人的にVBAのテクニックとして重要視しているのは**「配列を複数用意し適宜データを移し替える」**になります。いざ自力で開発となると非常に頭がこんがらがってしまうのですが、そういった際は焦らず配列の中身をセルに書き出したり、Stopステートメントを活用するなどしてじっくり動作確認を行いながら開発を進めてみて下さい！

## GetUniqueValues
~~~
Function GetUniqueValues(startRow As Long, startCol As Long, endRow As Long, endCol As Long, Optional targetSheet As Worksheet) As Variant
'------------------------------------------------------------------------------------------------------------------------------
'　概要　　｜セル範囲の内容で重複した内容を除外し1次元配列に抽出
'------------------------------------------------------------------------------------------------------------------------------
'　引数１　｜startRow - 開始行番号(Long型)
'　引数２　｜startCol - 開始列番号(Long型)
'　引数３　｜endRow - 終了行番号(Long型)
'　引数４　｜endCol - 終了列番号(Long型)
'　引数５　｜targetSheet - 対象のワークシートオブジェクト(規定値:ActiveSheet)(Worksheet型)
'------------------------------------------------------------------------------------------------------------------------------
'　戻り値　｜Variant型 - 重複した内容を除外した1次元配列
'------------------------------------------------------------------------------------------------------------------------------
'　実装　　｜Ver.1.0.0(2025/04/20:新規)
'------------------------------------------------------------------------------------------------------------------------------
    
    Dim arrSize         As Long 'インデックス番号
    Dim uniqueCount     As Long '非重複個数
    Dim vLoop           As Long '行ループカウンタ
    Dim hLoop           As Long '列ループカウンタ
    Dim checkIndex1     As Long 'インデックスループカウンタ
    Dim checkIndex2     As Long 'インデックスループカウンタ
    Dim valueList()     As Variant '格納用配列
    Dim uniqueList()    As Variant '非重複値格納用配列
    Dim surveyCell      As Range '指定セル範囲
    
    If targetSheet Is Nothing Then Set targetSheet = ActiveSheet
    
    'ユーザー定義エラー
    If startRow < 1 Or endRow < 1 Or startCol < 1 Or endCol < 1 Then
        Err.Raise vbObjectError + 1001, "GetUniqueValues", "引数は1以上の整数にしてください"
    End If
    If startRow > endRow Or startCol > endCol Then
        Err.Raise vbObjectError + 1002, "GetUniqueValues", "開始の数値は終了よりも小さいものにしてください"
    End If
    
    arrSize = 1
    
    'セル内容の抽出
    For vLoop = 1 To endRow - startRow + 1
        For hLoop = 1 To endCol - startCol + 1
            Set surveyCell = targetSheet.Cells(vLoop + startRow - 1, hLoop + startCol - 1)
            If surveyCell.Value <> "" Then
                ReDim Preserve valueList(arrSize)
                valueList(arrSize) = surveyCell.Value
                arrSize = arrSize + 1
            End If
        Next hLoop
    Next vLoop
    
    '重複内容をuniqueListに移し替え
    uniqueCount = 1
    arrSize = arrSize - 1
    ReDim Preserve uniqueList(uniqueCount)
    
    For checkIndex1 = 1 To arrSize
        For checkIndex2 = uniqueCount To 1 Step -1
            '重複を確認した場合
            If uniqueList(checkIndex2) = valueList(checkIndex1) Then GoTo Skip1
        Next checkIndex2
        uniqueList(uniqueCount) = valueList(checkIndex1)
        ReDim Preserve uniqueList(uniqueCount + 1)
        uniqueCount = uniqueCount + 1
Skip1:
    Next checkIndex1
    
    ReDim Preserve uniqueList(uniqueCount - 1)
    
    GetUniqueValues = uniqueList
    
End Function
~~~

使い方は第3回でご紹介した**CellToArray**と同じです！ユニークな値を抽出したいセル範囲を数字で指定してください。

![Excel-9-1.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/4046902/79abcf2d-5d6d-4740-9a9d-7ebfcd64d4e2.png)

このような表があったとしましょう、A1セルからG7セルまでの範囲でユニークな値を取得してみます。

~~~
Sub Main()
    
    Dim i As Long
    Dim A As Variant
    
    A = GetUniqueValues(1, 1, 7, 7)
    
    For i = 1 To UBound(A)
        Debug.Print A(i)
    Next i
    
End Sub
~~~

すると出力はこのようになります。

![Excel-9-2.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/4046902/035f1bb9-d410-4214-b7ed-48a30327c151.png)

重複のない苗字の一覧が完成しました！出力の配列を**PasteArray**を使って別シートに貼り付けたりするのもいいですね。また、空白セルは無視しております。

## GetDuplicateValues
~~~
Function GetDuplicateValues(startRow As Long, startCol As Long, endRow As Long, endCol As Long, Optional targetSheet As Worksheet) As Variant
'------------------------------------------------------------------------------------------------------------------------------
'　概要　　｜セル範囲の内容で重複した内容のみを1次元配列に抽出
'------------------------------------------------------------------------------------------------------------------------------
'　引数１　｜startRow - 開始行番号(Long型)
'　引数２　｜startCol - 開始列番号(Long型)
'　引数３　｜endRow - 終了行番号(Long型)
'　引数４　｜endCol - 終了列番号(Long型)
'　引数５　｜targetSheet - 対象のワークシートオブジェクト(規定値:ActiveSheet)(Worksheet型)
'------------------------------------------------------------------------------------------------------------------------------
'　戻り値　｜Variant型 - 重複した内容のみを抽出した1次元配列
'------------------------------------------------------------------------------------------------------------------------------
'　実装　　｜Ver.1.0.0(2025/04/20:新規)
'------------------------------------------------------------------------------------------------------------------------------
    
    Dim arrSize         As Long 'インデックス番号
    Dim dupCount        As Long '重複個数
    Dim vLoop           As Long '行ループカウンタ
    Dim hLoop           As Long '列ループカウンタ
    Dim checkIndex1     As Long 'インデックスループカウンタ
    Dim checkIndex2     As Long 'インデックスループカウンタ
    Dim checkIndex3     As Long 'インデックスループカウンタ
    Dim valueList()     As Variant '格納用配列
    Dim dupList()       As Variant '重複値格納用配列
    Dim surveyCell      As Range '指定セル範囲
    
    If targetSheet Is Nothing Then Set targetSheet = ActiveSheet
    
    'ユーザー定義エラー
    If startRow < 1 Or endRow < 1 Or startCol < 1 Or endCol < 1 Then
        Err.Raise vbObjectError + 1001, "GetDuplicateValues", "引数は1以上の整数にしてください"
    End If
    If startRow > endRow Or startCol > endCol Then
        Err.Raise vbObjectError + 1002, "GetDuplicateValues", "開始の数値は終了よりも小さいものにしてください"
    End If
    
    arrSize = 1
    
    'セル内容の抽出
    For vLoop = 1 To endRow - startRow + 1
        For hLoop = 1 To endCol - startCol + 1
            Set surveyCell = targetSheet.Cells(vLoop + startRow - 1, hLoop + startCol - 1)
            If surveyCell.Value <> "" Then
                ReDim Preserve valueList(arrSize)
                valueList(arrSize) = surveyCell.Value
                arrSize = arrSize + 1
            End If
        Next hLoop
    Next vLoop
    
    '重複内容をdupListに移し替え
    dupCount = 1
    arrSize = arrSize - 1
    ReDim Preserve dupList(dupCount)
    
    For checkIndex1 = 2 To arrSize
        For checkIndex2 = checkIndex1 - 1 To 1 Step -1
            '重複を確認した場合
            If valueList(checkIndex2) = valueList(checkIndex1) Then
                For checkIndex3 = 1 To dupCount
                    If dupList(checkIndex3) = valueList(checkIndex1) Then GoTo Skip1
                Next checkIndex3
                dupList(dupCount) = valueList(checkIndex1) '重複しつつ、dupList内に存在しなければ追加
                ReDim Preserve dupList(dupCount + 1)
                dupCount = dupCount + 1
                Exit For
Skip1:
            End If
        Next checkIndex2
    Next checkIndex1
    
    ReDim Preserve dupList(dupCount - 1)
    
    GetDuplicateValues = dupList
        
End Function
~~~

先ほどはユニークな値を取得しておりましたが今度は重複した値のみを取得します。同じ表に対してA1セルからG7セルまでの重複した値を取得してみましょう。

~~~
Sub Main()
    
    Dim i As Long
    Dim A As Variant
    
    A = GetDuplicateValues(1, 1, 7, 7)
    
    For i = 1 To UBound(A)
        Debug.Print A(i)
    Next i
    
End Sub
~~~

出力はこのようになります。

![Excel-9-3.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/4046902/07e2d7ee-508f-478a-813b-8204abf96070.png)

すみません重複を作りすぎてわかりにくくなってしまいましたが、GetUniqueValuesの出力結果から"井上"さん、"佐々木"さん、"月見里"さん、"四月一日"さんが除かれております。

重複チェックなどデータベースの確認って人力で行うと目が痛くなりますし抜けが起こりやすかったりしますので、**GetUniqueValues**と**GetDuplicateValues**を駆使して爆速で終わらせちゃいましょう！

## 直感！VBAシリーズ記事一覧
もしよろしければ他の記事もご覧ください！

https://qiita.com/Reko/items/3e482f9a73353e964f00

https://qiita.com/Reko/items/af042ae33cdc01e1dc96

https://qiita.com/Reko/items/9e211c9c496e12283f33

https://qiita.com/Reko/items/c2dab7b0e8207f8049df

https://qiita.com/Reko/items/b5abcdf614cef5d4073a

https://qiita.com/Reko/items/3451339e723a34ac7897

https://qiita.com/Reko/items/40c66556ac51a8006ea6

https://qiita.com/Reko/items/0269b2bece07a675e797

https://qiita.com/Reko/items/e2d0d0bf2dea4feface1

https://qiita.com/Reko/items/bc97d79599cfd431b2f3

https://qiita.com/Reko/items/1731aaddfc6e50c209df

https://qiita.com/Reko/items/554a47f2aa944e2eec5e

https://qiita.com/Reko/items/e8253ac68ccafba44ad3