Geminiと100本ノック 9本目：フィルターコピー

公開日：2025-04-29　最終更新日：2025-05-08

Geminiと100本ノック 9本目：フィルターコピー

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

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

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

VBA100本ノックの出題と解答

VBA100本ノック 9本目：フィルターコピー

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

Geminiへの出題とGeminiの回答

Geminiの回答 Geminiへの出題

VBA問題
「成績表」シートに5教科の成績とG列に合否判定があります。
「合格者」シートを新規作成し、合格者の氏名だけをA列に列挙してください。
※点数は非公開なので「合格者」シートには間違っても出力しないでください。
※何度でも実行できるようにしてください。

VBA マクロ Gemini 100本ノック AI神髄VBAVBA マクロ Gemini 100本ノック AI神髄VBA

はい、承知いたしました。「成績表」シートから合格者の氏名のみを抽出し、「合格者」シートに一覧として出力するVBAコードを作成します。

以下のVBAコードを標準モジュールに貼り付けて実行してください。

VBA


        
          
            Sub ExtractPassedStudents()


　　Dim ws成績表 As Worksheet

　　Dim ws合格者 As Worksheet

　　Dim lastRow成績表 As Long

　　Dim nextRow合格者 As Long

　　Dim i As Long


　　' 成績表シートを設定

　　On Error Resume Next

　　Set ws成績表 = ThisWorkbook.Sheets("成績表")

　　On Error GoTo 0


　　If ws成績表 Is Nothing Then

　　　　MsgBox "「成績表」シートが見つかりません。", vbCritical

　　　　Exit Sub

　　End If


　　' 「合格者」シートが存在すれば削除

　　On Error Resume Next

　　Application.DisplayAlerts = False

　　ThisWorkbook.Sheets("合格者").Delete

　　Application.DisplayAlerts = True

　　On Error GoTo 0


　　' 新規に「合格者」シートを作成

　　Set ws合格者 = ThisWorkbook.Sheets.Add

　　ws合格者.Name = "合格者"


　　' ヘッダーを記述

　　ws合格者.Cells(1, 1).Value = "氏名"


　　' 成績表シートの最終行を取得

　　lastRow成績表 = ws成績表.Cells(Rows.Count, "A").End(xlUp).Row


　　' 合格者シートの書き込み開始行を設定

　　nextRow合格者 = 2


　　' 成績表シートのデータを1行ずつ確認

　　For i = 2 To lastRow成績表 ' 1行目はヘッダーなので2行目から開始

　　　　' G列（合否判定）が「合格」の場合

　　　　If ws成績表.Cells(i, "G").Value = "合格" Then

　　　　　　' A列（氏名）を合格者シートにコピー

　　　　　　ws合格者.Cells(nextRow合格者, "A").Value = ws成績表.Cells(i, "A").Value

　　　　　　' 次の書き込み行に進む

　　　　　　nextRow合格者 = nextRow合格者 + 1

　　　　End If

　　Next i


　　' 合格者シートをアクティブにする

　　ws合格者.Activate


　　MsgBox "合格者の抽出が完了しました。", vbInformation


End Sub

コードの説明:

ExtractPassedStudents という名前のマクロを開始します。
必要な変数を宣言します。
"成績表" という名前のシートが存在するかを確認します。存在しない場合はメッセージを表示して終了します。
"合格者" という名前のシートが既に存在する場合は、警告を表示せずに削除します。これにより、何度実行しても新しいシートが作成されます。
新しいシートを作成し、"合格者" という名前に変更します。
"合格者" シートのA1セルにヘッダーとして "氏名" を入力します。
"成績表" シートのデータが入力されている最終行を取得します。
"合格者" シートへの書き込みを開始する行を2行目（ヘッダーの次）に設定します。
"成績表" シートの2行目から最終行までをループ処理します。
各行のG列の値が "合格" であるかを確認します。
G列が "合格" の場合、その行のA列（氏名）の値を "合格者" シートの次の空いている行のA列にコピーします。
次の合格者の氏名を書き込むために、"合格者" シートの書き込み行を1つ増やします。
ループが終了したら、作成した "合格者" シートをアクティブにします。
完了のメッセージを表示します。

このコードを実行すると、「成績表」シートの内容に基づき、合格者の氏名だけが列挙された新しい「合格者」シートが作成されます。実行するたびに既存の「合格者」シートは置き換えられます。

とても基本的なVBAで良いと思います。
ただし、データ行数が多い時には処理時間が気になってきます。

GeminiへのVBAコードの改善提案

Geminiの回答 Geminiへの出題

データ行数が多いと処理時間がかかりそうです。
もっと高速に処理できるVBAにしてください。

はい、データ量が多い場合の処理速度向上ですね。セルへの直接的な読み書きを減らし、配列処理を導入することで高速化を図ります。

以下の改良版VBAコードを使用してください。

VBA


        
          
            Sub ExtractPassedStudents_Fast()


　　Dim ws成績表 As Worksheet

　　Dim ws合格者 As Worksheet

　　Dim lastRow成績表 As Long

　　Dim data As Variant ' データを読み込む配列

　　Dim passedNames As Collection ' 合格者の氏名を一時的に格納

　　Dim name As Variant

　　Dim outputArray() As Variant ' 出力用配列

　　Dim i As Long

　　Dim j As Long ' 出力用配列のインデックス


　　' 画面更新と自動計算を一時的に停止

　　Application.ScreenUpdating = False

　　Application.Calculation = xlCalculationManual


　　' 成績表シートを設定

　　On Error Resume Next

　　Set ws成績表 = ThisWorkbook.Sheets("成績表")

　　On Error GoTo 0


　　If ws成績表 Is Nothing Then

　　　　MsgBox "「成績表」シートが見つかりません。", vbCritical

　　　　GoTo Cleanup

　　End If


　　' 「合格者」シートが存在すれば削除

　　On Error Resume Next

　　Application.DisplayAlerts = False

　　ThisWorkbook.Sheets("合格者").Delete

　　Application.DisplayAlerts = True

　　On Error GoTo 0


　　' 新規に「合格者」シートを作成

　　Set ws合格者 = ThisWorkbook.Sheets.Add

　　ws合格者.Name = "合格者"


　　' ヘッダーを記述

　　ws合格者.Cells(1, 1).Value = "氏名"


　　' 成績表シートのデータ範囲を配列に読み込む

　　lastRow成績表 = ws成績表.Cells(Rows.Count, "A").End(xlUp).Row

　　If lastRow成績表 < 2 Then ' ヘッダー行しかない場合

　　　　MsgBox "「成績表」シートにデータがありません。", vbInformation

　　　　GoTo Cleanup

　　End If

　　' データ範囲はA列からG列までと仮定

　　data = ws成績表.Range("A1:G" & lastRow成績表).Value


　　' 合格者の氏名をCollectionに抽出

　　Set passedNames = New Collection

　　For i = 2 To UBound(data, 1) ' 配列の2行目から最後までループ

　　　　' 配列の7列目（G列に相当）が「合格」の場合

　　　　If data(i, 7) = "合格" Then

　　　　　　' 配列の1列目（A列に相当、氏名）をCollectionに追加

　　　　　　passedNames.Add data(i, 1)

　　　　End If

　　Next i


　　' Collectionが空でない場合、出力用配列に変換してシートに書き出す

　　If passedNames.Count > 0 Then

　　　　' 出力用配列のサイズを設定 (要素数, 1列)

　　　　ReDim outputArray(1 To passedNames.Count, 1 To 1)

　　　　j = 1 ' 出力用配列のインデックス


　　　　' Collectionから配列にデータを移す

　　　　For Each name In passedNames

　　　　　　outputArray(j, 1) = name

　　　　　　j = j + 1

　　　　Next name


　　　　' 合格者シートに配列の内容を一度に書き出す

　　　　ws合格者.Range("A2").Resize(UBound(outputArray, 1), 1).Value = outputArray

　　End If


　　' 合格者シートをアクティブにする

　　ws合格者.Activate


　　MsgBox "合格者の抽出が完了しました。", vbInformation


Cleanup:

　　' 画面更新と自動計算を元に戻す

　　Application.ScreenUpdating = True

　　Application.Calculation = xlCalculationAutomatic


End Sub

高速化のための主な変更点:

配列の利用: "成績表" シートのデータを data という配列に一度に読み込んでいます (ws成績表.Range("A1:G" & lastRow成績表).Value)。シートのセルに直接アクセスするよりも、メモリ上の配列にアクセスする方がはるかに高速です。
Collectionによる抽出: 合格者の氏名を passedNames という Collection オブジェクトに一時的に格納しています。これにより、合格者リストを効率的に構築できます。
配列での一括書き出し: 抽出した氏名を outputArray という配列に格納し直し、その配列の内容を "合格者" シートのRangeに一度に書き出しています (ws合格者.Range("A2").Resize(...).Value = outputArray)。セルに1つずつ書き込むよりも高速です。
画面更新と自動計算の停止: Application.ScreenUpdating = False と Application.Calculation = xlCalculationManual をコードの最初で設定し、処理が終わった後で True と xlCalculationAutomatic に戻しています。これにより、VBAが実行されている間に画面のちらつきや不要な再計算を防ぎ、処理速度が向上します。

これらの変更により、特にデータ行数が多い場合に、最初のコードよりも格段に速く処理が完了するはずです。

全体としては良さそうですが、ちょっとぎこちないVBAに見えますね。
もっと具体的なVBAの書き方を指示しないと、なかなか私の気に入ったVBAにはならないかもしれないですね。
それにはプロンプトをもっと工夫する必要がありそうです。
ですが、毎回プロンプトを詳しく書くのは効率が悪すぎます。
ということで、「AI神髄VBA」を作成しました。

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

AI神髄VBAとは、GeminiのGems機能を使って作ったVBAに特化したカスタムAIです。
Gemのカスタム指示はシリーズを通して改良していきますので、シリーズ終了後に公開予定です。

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

はい、承知いたしました。「成績表」シートから合格者の氏名だけを抽出し、「合格者」シートに列挙するVBAコードを作成します。AutoFilter機能を使用して、シンプルかつ高速な処理を目指します。

VBA


        
          
            Sub 合格者リスト作成()


　　'定数定義

　　Const SOURCE_SHEET_NAME As String = "成績表"

　　Const DEST_SHEET_NAME As String = "合格者"

　　Const JUDGEMENT_COLUMN As Long = 7 'G列

　　Const JUDGEMENT_CRITERIA As String = "合格"

　　Const NAME_COLUMN As String = "A" '氏名列


　　Dim wsSource As Worksheet

　　Dim wsDest As Worksheet

　　Dim lastRow As Long


　　'画面更新を停止

　　Application.ScreenUpdating = False


　　'「成績表」シートを設定

　　Set wsSource = ThisWorkbook.Sheets(SOURCE_SHEET_NAME)


　　'「合格者」シートが存在すれば削除

　　On Error Resume Next

　　Application.DisplayAlerts = False

　　ThisWorkbook.Sheets(DEST_SHEET_NAME).Delete

　　Application.DisplayAlerts = True

　　On Error GoTo 0


　　'「合格者」シートを新規作成

　　Set wsDest = ThisWorkbook.Sheets.Add(After:=wsSource)

　　wsDest.Name = DEST_SHEET_NAME


　　'オートフィルターを設定

　　With wsSource

　　　　'オートフィルターがかかっていたら解除

　　　　If .AutoFilterMode Then .AutoFilter.ShowAllData


　　　　'データの最終行を取得

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


　　　　'データがヘッダー行のみの場合は処理を抜ける

　　　　If lastRow < 2 Then Exit Sub


　　　　'合否判定列でフィルタリング

　　　　.Range(.Cells(1, 1), .Cells(lastRow, JUDGEMENT_COLUMN)).AutoFilter Field:=JUDGEMENT_COLUMN, Criteria1:=JUDGEMENT_CRITERIA


　　　　'フィルタリングされた氏名列（可視セル）をコピーして貼り付け

　　　　'ヘッダー行（1行目）はコピーしない

　　　　.Range(.Cells(2, NAME_COLUMN), .Cells(lastRow, NAME_COLUMN)).SpecialCells(xlCellTypeVisible).Copy wsDest.Range("A1")


　　　　'オートフィルターを解除

　　　　.AutoFilter.ShowAllData

　　End With


　　'画面更新を再開

　　Application.ScreenUpdating = True


　　MsgBox "合格者リストを作成しました。", vbInformation


            End Sub

コードの説明:

定数定義: 使用するシート名、合否判定列、判定基準、氏名列を定数として定義しています。これにより、コードの見通しが良くなり、変更があった場合の修正が容易になります。
画面更新停止: 処理中の画面のちらつきを抑え、処理速度を向上させます。
シート設定: "成績表" シートを変数に設定します。
既存シート削除: "合格者" という名前のシートが既に存在する場合、エラーを無視して削除します。これにより、何度実行しても常に新しいリストが作成されます。Application.DisplayAlerts = False で削除時の警告メッセージを表示しないようにしています。
新規シート作成: 新しく "合格者" シートを作成し、変数に設定します。
AutoFilter設定:
- もし既にオートフィルターが設定されていた場合、一度解除します。
- "成績表" シートのデータ範囲の最終行を取得します。
- データがヘッダー行しかない場合は、以降の処理を行わずに終了します (アーリーリターン)。
- 指定した合否判定列 (G列) で "合格" を基準にフィルタリングを実行します。
データコピー＆貼り付け:
- フィルタリングによって表示されている行の中で、氏名列 (A列) のセルを SpecialCells(xlCellTypeVisible) を使用して取得します。これにより、非表示の行のデータは含まれません。
- ヘッダー行（1行目）を除いた2行目から最終行までの可視セルをコピーし、"合格者" シートのA1セルに貼り付けます。
AutoFilter解除: "成績表" シートのオートフィルターを解除し、すべてのデータが表示された状態に戻します。
画面更新再開: 画面更新を再開します。
完了メッセージ: 処理が完了したことを示すメッセージボックスを表示します。

このコードは、Forループを使用せず、Excelのデータベース機能であるAutoFilterと可視セルのコピーを活用しているため、データ量が多くても高速に処理されます。

良くかけていると思います。
自分ならこう書くというのはありますが、もうそれは個人の好みの範疇だと思います。
AIが書くVBAとしては申し分ないです。
それどころか、これがAIが書いたVBAだとは…
10年前の自分に言っても信じないかもしれません(笑)

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

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

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

ホーム
その他
生成AI活用研究
Geminiと100本ノック 9本目：フィルターコピー

このサイトがお役に立ちましたら「シェア」「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本ノック 9本目：フィルターコピー