第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シリーズ記事一覧
もしよろしければ他の記事もご覧ください！