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

今回ご紹介するプロシージャは

プロシージャ名	概要
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と同じです！ユニークな値を抽出したいセル範囲を数字で指定してください。

このような表があったとしましょう、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

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

重複のない苗字の一覧が完成しました！出力の配列を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

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

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

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

直感！VBAシリーズ記事一覧

もしよろしければ他の記事もご覧ください！