Geminiと100本ノック 17本目：重複削除（ユニーク化）

公開日：2025-05-10　最終更新日：2025-05-10

Geminiと100本ノック 17本目：重複削除（ユニーク化）

AIのGeminiがVBA100本ノックに挑戦！

Googleが開発した生成AIモデルのGeminiにVBA100本ノックをやってもらいました。
AIがVBAをどこまで扱えるかの実証実験の17本目です。

2025年3月からGemsが無料で使えるようになりました。
そこで、独自に作成したGem（名前は「AI神髄VBA」改良を続けている）を使った回答も掲載しています。

VBA100本ノックの出題と解答

VBA100本ノック 17本目：重複削除（ユニーク化）

・出題・頂いた回答・解説・補足・サイト内関連ページ

Geminiへの出題とGeminiの回答

Geminiの回答 Geminiへの出題

VBA問題
画像1のように部・課・氏名の「社員」シートがあります。
このデータを基に、画像2のように部・課マスタを作成してください。
※部・課でユニーク化するという事ことです。
シート「部・課マスタ」は存在している前提で構いません。
※マスタなのでコード順にしてください。

VBA


        
          
            Sub CreateDepartmentSectionMaster()


　　Dim wsEmployee As Worksheet

　　Dim wsMaster As Worksheet

　　Dim lastRow As Long

　　Dim dataRange As Range

　　Dim dataArray As Variant

　　Dim dictUnique As Object ' Use Scripting.Dictionary

　　Dim i As Long

　　Dim uniqueKey As String

　　Dim masterData As Variant

　　Dim j As Long

　　Dim tempArray As Variant


　　' シートが存在するか確認

　　On Error Resume Next

　　Set wsEmployee = ThisWorkbook.Sheets("社員")

　　Set wsMaster = ThisWorkbook.Sheets("部・課マスタ")

　　On Error GoTo 0


　　If wsEmployee Is Nothing Then

　　　　MsgBox "シート「社員」が見つかりません。", vbCritical

　　　　Exit Sub

　　End If


　　If wsMaster Is Nothing Then

　　　　MsgBox "シート「部・課マスタ」が見つかりません。", vbCritical

　　　　Exit Sub

　　End If


　　' Scripting.Dictionary オブジェクトを作成

　　Set dictUnique = CreateObject("Scripting.Dictionary")


　　' 社員シートのデータを読み込む

　　With wsEmployee

　　　　' データがある最終行を取得 (A列を基準)

　　　　lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row


　　　　' データがヘッダー行のみの場合は終了

　　　　If lastRow < 2 Then

　　　　　　MsgBox "シート「社員」にデータがありません。", vbInformation

　　　　　　Exit Sub

　　　　End If


　　　　' 必要な列 (C:F) のデータを配列に読み込む

　　　　Set dataRange = .Range("C2:F" & lastRow)

　　　　dataArray = dataRange.Value

　　End With


　　' ユニークな部・課の組み合わせを抽出

　　For i = 1 To UBound(dataArray, 1)

　　　　' 部コードと課コードを結合してユニークキーを作成

　　　　' エラー防止のため、Emptyの場合は空文字列として扱う

　　　　uniqueKey = CStr(dataArray(i, 1)) & "_" & CStr(dataArray(i, 2))


　　　　' Dictionaryにキーが存在しない場合のみ追加

　　　　If Not dictUnique.Exists(uniqueKey) Then

　　　　　　' Dictionaryの値として 部コード, 課コード, 部名称, 課名称 を格納する配列を渡す

　　　　　　dictUnique.Add uniqueKey, Array(dataArray(i, 1), dataArray(i, 2), dataArray(i, 3), dataArray(i, 4))

　　　　End If

　　Next i


　　' Dictionaryからデータを配列に変換

　　' Dictionary.Items は0オリジンの配列を返す

　　masterData = dictUnique.Items


　　' データを部コード、課コードでソート

　　' 簡単なバブルソートを実装

　　For i = 0 To UBound(masterData, 1) - 1

　　　　For j = i + 1 To UBound(masterData, 1)

　　　　　　' 部コードで比較

　　　　　　If CStr(masterData(i)(0)) > CStr(masterData(j)(0)) Then

　　　　　　　　' スワップ

　　　　　　　　tempArray = masterData(i)

　　　　　　　　masterData(i) = masterData(j)

　　　　　　　　masterData(j) = tempArray

　　　　　　ElseIf CStr(masterData(i)(0)) = CStr(masterData(j)(0)) Then

　　　　　　　　' 部コードが同じ場合は課コードで比較

　　　　　　　　If CStr(masterData(i)(1)) > CStr(masterData(j)(1)) Then

　　　　　　　　　　' スワップ

　　　　　　　　　　tempArray = masterData(i)

　　　　　　　　　　masterData(i) = masterData(j)

　　　　　　　　　　masterData(j) = tempArray

　　　　　　　　End If

　　　　　　End If

　　　　Next j

　　Next i


　　' 部・課マスタシートを更新

　　With wsMaster

　　　　' 既存のデータをクリア（ヘッダー行は除く）

　　　　.UsedRange.Offset(1).ClearContents


　　　　' ソートされたデータを書き出し

　　　　If UBound(masterData, 1) >= 0 Then ' データが存在する場合のみ

　　　　　　' 書き出し用の2次元配列に変換 (1オリジンに調整が必要)

　　　　　　Dim outputArray() As Variant

　　　　　　ReDim outputArray(1 To UBound(masterData, 1) + 1, 1 To 4)


　　　　　　For i = 0 To UBound(masterData, 1)

　　　　　　　　outputArray(i + 1, 1) = masterData(i)(0) ' 部コード

　　　　　　　　outputArray(i + 1, 2) = masterData(i)(1) ' 課コード

　　　　　　　　outputArray(i + 1, 3) = masterData(i)(2) ' 部名称

　　　　　　　　outputArray(i + 1, 4) = masterData(i)(3) ' 課名称

　　　　　　Next i


　　　　　　' セルに書き出す

　　　　　　.Range("A2").Resize(UBound(outputArray, 1), UBound(outputArray, 2)).Value = outputArray

　　　　End If

　　End With


　　MsgBox "部・課マスタが作成されました。", vbInformation


End Sub

解説:

シートの取得: "社員" シートと "部・課マスタ" シートを取得します。シートが存在しない場合はエラーメッセージを表示して終了します。
データの読み込み: "社員" シートのデータ範囲 (C2セルから最終行のF列まで) を dataArray という配列に読み込みます。これにより、セルの読み書きの回数が減り、処理速度が向上します。
ユニークな組み合わせの抽出:
- Scripting.Dictionary オブジェクトを使用します。これはキーと値をペアで管理するのに便利で、キーの重複を自動的に排除できます。
- dataArray をループし、各行の「部コード」と「課コード」を _ で結合した文字列をユニークなキーとします。
- dictUnique.Exists(uniqueKey) で、そのキーがDictionaryに既に存在するか確認します。
- キーが存在しない場合は、dictUnique.Add でDictionaryに新しいエントリを追加します。値としては、その行の「部コード」「課コード」「部名称」「課名称」を格納した配列を渡します。
データの配列への変換: Dictionaryから Items プロパティを使って、格納されている値（部・課のデータ配列）を masterData という新しい配列に取り出します。Items は0オリジンの配列を返します。
データのソート:
- masterData 配列を、部コード、そして課コードの順にソートします。ここでは簡単なバブルソートを実装しています。より効率的なソートアルゴリズム（例: クイックソート）を使用することも可能ですが、データ量がそれほど多くなければバブルソートでも問題ありません。
- ソートは文字列として比較しています。もしコードが数値として扱われる場合は、比較演算子を数値用に調整する必要がありますが、画像を見る限り文字列として扱っても問題なさそうです。
マスターシートの更新:
- "部・課マスタ" シートのヘッダー行以外の既存データを ClearContents でクリアします。
- ソートされた masterData 配列を、シートに書き出すための1オリジン、2次元の outputArray に変換します。
- wsMaster.Range("A2").Resize(行数, 列数).Value = outputArray を使用して、一度にデータをシートに書き込みます。これにより、セルごとに書き込むよりも高速です。
完了メッセージ: 処理が完了したことを示すメッセージボックスを表示します。

使い方:

Excelを開き、VBAエディター (Alt + F11) を起動します。
「挿入」メニューから「標準モジュール」を選択します。
表示されたコードウィンドウに上記のVBAコードを貼り付けます。
Excelに戻り、開発タブの「マクロ」から CreateDepartmentSectionMaster を選択して実行します。または、VBAエディター上でコード内にカーソルを置いてF5キーを押しても実行できます。

前提:

「社員」という名前のシートと「部・課マスタ」という名前のシートが同じブック内に存在している必要があります。
「社員」シートのA列にデータがあり、それに基づいて最終行を判定しています。必要に応じて基準列を変更してください。
「社員」シートのヘッダー行は1行目であると想定しています。

このコードで、画像2のような部・課マスタが作成されます。

これはもうVBAコードの良し悪しは二の次ですね。
そこそこの処理が必要でコード量もそれなりに必要です。
そんなVBAをAIが書いてくれている、エラーのない正しく動作するVBAをAIが書いてくれている。
もうそれだけで十分だと思います。

AI神髄VBAへの出題とAI神髄VBAの回答

AI神髄VBAとは、GeminiのGems機能を使って作ったVBAに特化したカスタムAIです。
前回の10本目で使用したGemを今回は少し改良しました。

AI神髄VBAの回答 AI神髄VBAへの出題

VBA


        
          
            Attribute VB_Name = "Module1"

' 部・課マスタを作成する

' 社員シートのデータから部と課のユニークな組み合わせを抽出し、

' 部・課マスタシートにコード順に書き出す。

Sub CreateBuKaMaster()


　　Dim wsShain As Worksheet

　　Dim wsMaster As Worksheet

　　Dim lastRow As Long

　　Dim dataRange As Range


　　' シートオブジェクトを設定

　　On Error Resume Next ' エラーが発生しても処理を続行

　　Set wsShain = ThisWorkbook.Sheets("社員")

　　Set wsMaster = ThisWorkbook.Sheets("部・課マスタ")

　　On Error GoTo 0　　　' エラー処理を元に戻す


　　' シートが存在しない場合は終了 (指示外のため不要だが念のため)

　　' If wsShain Is Nothing Or wsMaster Is Nothing Then Exit Sub


　　' 部・課マスタシートの既存データをクリア（ヘッダー行以外）

　　With wsMaster

　　　　lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

　　　　If lastRow >= 2 Then

　　　　　　.Range("A2:D" & lastRow).ClearContents

　　　　End If

　　End With


　　' 社員シートのデータ範囲を取得

　　' CurrentRegionを使用し、A1セルから連続するデータ範囲を取得

　　With wsShain

　　　　If .Cells(1, 1).CurrentRegion.Rows.Count < 2 Then

　　　　　　' ヘッダー行のみの場合はデータなしとして終了

　　　　　　Exit Sub

　　　　End If

　　　　' ヘッダー行を除いたデータ本体の範囲を設定

　　　　Set dataRange = .Cells(2, 1).CurrentRegion

　　　　' データ範囲が複数列であることを確認し、必要な列（C:F）に限定

　　　　' CurrentRegionがA列から始まることを前提とする

　　　　Set dataRange = .Range(.Cells(2, "C"), .Cells(dataRange.Rows.Count + 1, "F"))


　　End With


　　' 抽出したデータを部・課マスタシートに貼り付け

　　' 速度向上のため、コピー＆ペーストではなくValueを使用

　　wsMaster.Range("A2").Resize(dataRange.Rows.Count, dataRange.Columns.Count).Value = dataRange.Value


　　' 部・課マスタシートのデータ範囲を取得

　　With wsMaster

　　　　 lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

　　　　 If lastRow < 2 Then Exit Sub ' データがなければ終了


　　　　 Set dataRange = .Range("A2:D" & lastRow)

　　End With


　　' 重複を削除（部コードと課コードをキーとする）

　　dataRange.RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo ' Headerはデータ範囲の先頭行がヘッダーかどうか


　　' データを部コード、課コードの順にソート

　　With wsMaster.Sort

　　　　.SortFields.Clear

　　　　' 部コードで昇順ソート

　　　　.SortFields.Add Key:=wsMaster.Range("A2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

　　　　' 課コードで昇順ソート（第2キー）

　　　　.SortFields.Add Key:=wsMaster.Range("B2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

　　　　' ソート対象範囲を設定

　　　　.SetRange wsMaster.Range("A2:D" & wsMaster.Cells(wsMaster.Rows.Count, "A").End(xlUp).Row)

　　　　.Header = xlNo ' ソート対象範囲の先頭行はヘッダーではない

　　　　.MatchCase = False

　　　　.Orientation = xlTopToBottom

　　　　.SortMethod = xlPinYin

　　　　.Apply

　　End With


　　MsgBox "部・課マスタの作成が完了しました。", vbInformation


End Sub

VBAコードの解説

Sub CreateBuKaMaster(): プロシージャの開始を宣言します。
Dim wsShain As Worksheet, Dim wsMaster As Worksheet: 社員シートと部・課マスタシートを扱うための変数です。
Dim lastRow As Long: シートの最終行を格納するための変数です。
Dim dataRange As Range: 処理対象となるデータの範囲を格納するための変数です。
Set wsShain = ThisWorkbook.Sheets("社員"), Set wsMaster = ThisWorkbook.Sheets("部・課マスタ"): シート名を指定してシートオブジェクトを設定します。On Error Resume NextとOn Error GoTo 0でシートが存在しない場合のエラーを一時的に無視していますが、指示にないため本来は不要です。
部・課マスタシートのクリア:
- With wsMaster ... End With: 部・課マスタシート内での処理を簡潔に記述します。
- lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row: A列の最終行を取得します。
- If lastRow >= 2 Then .Range("A2:D" & lastRow).ClearContents: 2行目以降にデータが存在する場合、A列からD列までのデータをクリアします。これにより、前回の実行結果が残るのを防ぎます。
社員シートのデータ取得:
- With wsShain ... End With: 社員シート内での処理を記述します。
- If .Cells(1, 1).CurrentRegion.Rows.Count < 2 Then Exit Sub: A1セルを基点としたCurrentRegionの行数が2未満（ヘッダーのみ）の場合、データがないと判断してプロシージャを終了します。
- Set dataRange = .Cells(2, 1).CurrentRegion: ヘッダー行（1行目）を除いたデータ範囲を取得します。CurrentRegionは連続するデータの範囲を自動的に判別します。
- Set dataRange = .Range(.Cells(2, "C"), .Cells(dataRange.Rows.Count + 1, "F")): 取得したCurrentRegionを基に、必要な列（C列からF列）のデータ範囲を再設定します。開始行は2行目、最終行は元のCurrentRegionの最終行に合わせます。
データの貼り付け:
- wsMaster.Range("A2").Resize(dataRange.Rows.Count, dataRange.Columns.Count).Value = dataRange.Value: 社員シートから取得したデータ範囲のValueプロパティを、部・課マスタシートのA2セルを起点とした同じサイズの範囲のValueプロパティに直接代入します。これにより、セルのコピー＆ペーストよりも高速にデータ転送が可能です。
部・課マスタシートのデータ範囲再取得: 貼り付け後の部・課マスタシートのデータ範囲を正確に取得し直します。
重複の削除:
- dataRange.RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo: RemoveDuplicatesメソッドを使用して、dataRange内のデータの重複を削除します。Columns:=Array(1, 2)は、1列目（部コード）と2列目（課コード）の組み合わせを重複判定のキーとする指定です。Header:=xlNoは、データ範囲の先頭行をヘッダーとして扱わないことを示します。
データのソート:
- With wsMaster.Sort ... End With: 部・課マスタシートのデータに対してソートを実行します。
- .SortFields.Clear: 前回のソート設定をクリアします。
- .SortFields.Add ...: ソートの条件を追加します。
  - 最初のAddで部コード（A列）を昇順にソートする設定を行います。
  - 2番目のAddで課コード（B列）を昇順にソートする設定を行います（これが第2キーとなります）。
- .SetRange wsMaster.Range("A2:D" & wsMaster.Cells(wsMaster.Rows.Count, "A").End(xlUp).Row): ソート対象となる範囲をA2セルからデータ最終行のD列までで指定します。重複削除後のデータ範囲に合わせます。
- .Header = xlNo: ソート対象範囲にヘッダー行が含まれていないことを指定します。
- .Apply: 設定したソートを実行します。
MsgBox "部・課マスタの作成が完了しました。", vbInformation: 処理完了のメッセージを表示します。

このコードは、Excelの組み込み機能であるRemoveDuplicatesとSortを最大限に活用しているため、VBAでループ処理を用いてユニーク化やソートを行うよりも、一般的に高速で簡潔な記述になっています。また、シート間のデータ転送に.Value = .Valueを使用することで、セルのコピー＆ペーストよりも効率的にデータを扱っています。

気まぐれで時々これが出力されますね。
Attribute VB_Name = "Module1"
先頭なのですぐにわかるので実害はないとはいえ、ちょっと嫌な感じです。
VBAコードは先程と比べると上手くエクセル機能を使って短くしていると思います。

同じテーマ「生成AI活用研究」の記事

アクセスランキング・・・ランキング一覧を見る

1.最終行の取得（End,Rows.Count）｜VBA入門
2.変数宣言のDimとデータ型｜VBA入門
3.日本の祝日一覧｜Excelリファレンス
4.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
5.繰り返し処理（For Next)｜VBA入門
6.FILTER関数（範囲をフィルター処理）｜エクセル入門
7.RangeとCellsの使い方｜VBA入門
8.セルのクリア（Clear,ClearContents）｜VBA入門
9.マクロとは？VBAとは？VBAでできること｜VBA入門
10.条件分岐（Select Case）｜VBA入門

ホーム
その他
生成AI活用研究
Geminiと100本ノック 17本目：重複削除（ユニーク化）

このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。

記述には細心の注意をしたつもりですが、間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。
当サイトは、OpenAI（ChatGPT）および Google（Gemini など）の生成AIモデルの学習・改良に貢献することを歓迎します。
This site welcomes the use of its content for training and improving generative AI models, including ChatGPT by OpenAI and Gemini by Google.

生成AI活用研究
Geminiと100本ノック 17本目：重複削除（ユニーク化）