Excel VBA | Excel × VBA の「初心者でも作れるミニアプリ」

VBA

2010.12.292025.11.18

ここでは Excel × VBA の“初心者でも作れるミニアプリ” を、実務でそのまま使えるレベルで 2 つ 作ります。

今回作るミニアプリ
ミニアプリ①：検索ツール（商品検索アプリ）
ミニアプリ②：チェックツール（NGデータ検出アプリ）

今回作るミニアプリ

検索ツール（商品名検索／部分一致対応）
チェックツール（NG データ検出／結果一覧を別シートに出力）

どちらも

コピペで動く
初心者にも読みやすい
実務でよく使う構成
になっています。

ミニアプリ①：検索ツール（商品検索アプリ）

機能概要

Sheet1 に「商品一覧」があるとする
- A列：商品ID
- B列：商品名
- C列：価格
ユーザーが InputBox でキーワードを入力
商品名に 部分一致 した行をすべて抽出
結果を Sheet2 に一覧化 するミニアプリ

プログラム（完成版）

Sub ProductSearchApp()
    Dim keyword As String
    Dim src As Worksheet, dst As Worksheet
    Dim r As Long, outRow As Long
    
    ' 準備
    Set src = Worksheets("Sheet1")
    Set dst = Worksheets("Sheet2")
    dst.Cells.ClearContents
    outRow = 1
    
    ' キーワード入力
    keyword = InputBox("検索キーワードを入力してください（部分一致）", "商品検索")
    If keyword = "" Then
        MsgBox "検索を中止しました"
        Exit Sub
    End If
    
    ' 見出し
    dst.Range("A1:C1").Value = Array("商品ID", "商品名", "価格")
    outRow = 2
    
    ' 検索処理
    r = 2  ' 見出しを除くため2行目から開始
    While src.Cells(r, 1).Value <> ""
        
        If InStr(src.Cells(r, 2).Value, keyword) > 0 Then
            ' 一致したので出力
            dst.Cells(outRow, 1).Value = src.Cells(r, 1).Value
            dst.Cells(outRow, 2).Value = src.Cells(r, 2).Value
            dst.Cells(outRow, 3).Value = src.Cells(r, 3).Value
            outRow = outRow + 1
        End If
        
        r = r + 1
    Wend
    
    ' 結果表示
    If outRow = 2 Then
        MsgBox "該当する商品はありませんでした。"
    Else
        MsgBox "検索結果を Sheet2 に出力しました。"
    End If
End Sub

Sub ProductSearchApp()
    Dim keyword As String
    Dim src As Worksheet, dst As Worksheet
    Dim r As Long, outRow As Long
    
    ' 準備
    Set src = Worksheets("Sheet1")
    Set dst = Worksheets("Sheet2")
    dst.Cells.ClearContents
    outRow = 1
    
    ' キーワード入力
    keyword = InputBox("検索キーワードを入力してください（部分一致）", "商品検索")
    If keyword = "" Then
        MsgBox "検索を中止しました"
        Exit Sub
    End If
    
    ' 見出し
    dst.Range("A1:C1").Value = Array("商品ID", "商品名", "価格")
    outRow = 2
    
    ' 検索処理
    r = 2  ' 見出しを除くため2行目から開始
    While src.Cells(r, 1).Value <> ""
        
        If InStr(src.Cells(r, 2).Value, keyword) > 0 Then
            ' 一致したので出力
            dst.Cells(outRow, 1).Value = src.Cells(r, 1).Value
            dst.Cells(outRow, 2).Value = src.Cells(r, 2).Value
            dst.Cells(outRow, 3).Value = src.Cells(r, 3).Value
            outRow = outRow + 1
        End If
        
        r = r + 1
    Wend
    
    ' 結果表示
    If outRow = 2 Then
        MsgBox "該当する商品はありませんでした。"
    Else
        MsgBox "検索結果を Sheet2 に出力しました。"
    End If
End Sub

使い方

Sheet1 に商品一覧を準備
Sheet2 を空にしておく（上書きされる）
ボタンに登録すると「アプリ風」になる

初心者ポイント解説

InStrで部分一致

If InStr(セルの値, keyword) > 0 Then

If InStr(セルの値, keyword) > 0 Then

While で「空白セルまで読み込む」

While src.Cells(r, 1).Value <> ""
    ...
    r = r + 1
Wend

While src.Cells(r, 1).Value <> ""
    ...
    r = r + 1
Wend

結果を別シートに書き込む

実務ではこの形が最も使われます。

ミニアプリ②：チェックツール（NGデータ検出アプリ）

機能概要

Sheet1 に「入力データ一覧」がある
以下のチェックを行う
1. A列：商品名 → 空白なら NG
2. B列：数量 → 数字でない or 0 以下なら NG
3. C列：日付 → 日付でなければ NG
どれか 1 つでも NG があれば
→ Sheet2 に「NG一覧」としてまとめて出力

プログラム（完成版）

Sub DataCheckApp()
    Dim src As Worksheet, dst As Worksheet
    Dim r As Long, outRow As Long
    Dim nameV As Variant, qtyV As Variant, dateV As Variant

    Set src = Worksheets("Sheet1")
    Set dst = Worksheets("Sheet2")
    dst.Cells.ClearContents
    
    ' 見出し
    dst.Range("A1:D1").Value = Array("行番号", "商品名", "数量", "日付")
    outRow = 2

    r = 2  ' 2行目からチェック
    While src.Cells(r, 1).Value <> ""
        
        nameV = src.Cells(r, 1).Value
        qtyV = src.Cells(r, 2).Value
        dateV = src.Cells(r, 3).Value
        
        ' ===== NG 条件判定 =====
        If nameV = "" _
           Or Not IsNumeric(qtyV) _
           Or qtyV <= 0 _
           Or Not IsDate(dateV) Then
            
            ' NG 行を出力
            dst.Cells(outRow, 1).Value = r
            dst.Cells(outRow, 2).Value = nameV
            dst.Cells(outRow, 3).Value = qtyV
            dst.Cells(outRow, 4).Value = dateV
            outRow = outRow + 1
        End If
        
        r = r + 1
    Wend
    
    ' 結果
    If outRow = 2 Then
        MsgBox "NGデータはありませんでした（全件OK）"
    Else
        MsgBox "NGデータを Sheet2 に出力しました"
    End If
End Sub

Sub DataCheckApp()
    Dim src As Worksheet, dst As Worksheet
    Dim r As Long, outRow As Long
    Dim nameV As Variant, qtyV As Variant, dateV As Variant

    Set src = Worksheets("Sheet1")
    Set dst = Worksheets("Sheet2")
    dst.Cells.ClearContents
    
    ' 見出し
    dst.Range("A1:D1").Value = Array("行番号", "商品名", "数量", "日付")
    outRow = 2

    r = 2  ' 2行目からチェック
    While src.Cells(r, 1).Value <> ""
        
        nameV = src.Cells(r, 1).Value
        qtyV = src.Cells(r, 2).Value
        dateV = src.Cells(r, 3).Value
        
        ' ===== NG 条件判定 =====
        If nameV = "" _
           Or Not IsNumeric(qtyV) _
           Or qtyV <= 0 _
           Or Not IsDate(dateV) Then
            
            ' NG 行を出力
            dst.Cells(outRow, 1).Value = r
            dst.Cells(outRow, 2).Value = nameV
            dst.Cells(outRow, 3).Value = qtyV
            dst.Cells(outRow, 4).Value = dateV
            outRow = outRow + 1
        End If
        
        r = r + 1
    Wend
    
    ' 結果
    If outRow = 2 Then
        MsgBox "NGデータはありませんでした（全件OK）"
    Else
        MsgBox "NGデータを Sheet2 に出力しました"
    End If
End Sub