特徴マスタに登録した特徴があったら赤字にして特徴IDを隣列にだすよ

2025年2月9日 19:53

この説明は、ChatGPTで作成しています。

このVBAコードは、「特徴マスタ」シートに登録されている特徴ワードを、現在のシートのA列（2行目以降）で検索 し、
見つかった特徴ワードを赤字にし、対応する特徴IDを隣のセルに表示する という処理を行います。
また、「特徴マスタ」シートの検出回数と最新検出日を更新 します。

コードの流れ

「特徴マスタ」シートからデータを取得
- 「特徴マスタ」シートのA列（特徴ワード）～D列（最新検出日）までを配列に保存します。
現在のシートのA列を検索範囲として設定
- A列の2行目以降を検索対象とします。
特徴マスタのワードを順番に検索
- Find 関数を使って、特徴マスタにあるワードをA列から検索 します。
- 見つかった場合、その文字の色を赤（ColorIndex = 3） に変更します。
- 隣のセル（B列）に特徴IDを追記 します。
- さらに「特徴マスタ」の検出回数を+1 し、最新検出日を更新 します。
検索結果が複数ある場合、すべてのセルに対して同じ処理を繰り返す
- FindNext を使って、同じ特徴ワードがA列に複数あった場合、すべてに対して赤字＋特徴ID表示 を行います。
「特徴マスタ」シートのデータを更新
- 検索結果を反映した配列データを「特徴マスタ」シートに書き戻します。
処理完了のメッセージを表示
- MsgBox "チェック完了！" で、処理の終了を知らせます。

ポイント

配列を使って「特徴マスタ」シートのデータを一括で処理 することで、動作速度を速くしています。
「Find」と「FindNext」 を使って、複数回検索を実行しています。
見つかった特徴ワードの位置を特定して、該当部分のみ赤字 に変更する処理をしています。
特徴IDをB列に追記 する際、すでに値がある場合は「,」で区切って追加 しています。

関連リンク

Sub 特徴マスタに登録した特徴があったら赤字にして特徴IDを隣列にだすよ()
    Application.ScreenUpdating = False
    
    'マスターを配列に保存する
    Dim wsm As Worksheet
    Set wsm = Worksheets("特徴マスタ")
    Dim lastRow As Long, lastCol As Long
    lastRow = wsm.Cells(wsm.Rows.count, 1).End(xlUp).Row
    lastCol = wsm.Cells(1, wsm.Columns.count).End(xlToLeft).Column

    Dim Master As Variant
    'マスターのテーブル範囲を設定（見出し含まず）
'    マスターテーブルA列「特徴word」B列「特徴ID」C列「検出回数」D列「最新検出日」
    Master = wsm.Range(wsm.Cells(2, 1), wsm.Cells(lastRow, lastCol)).Value
    
    Dim ws As Worksheet
    Set ws = ActiveSheet
    ws.Activate
    
    '検索範囲を制限（列1、行2以降）
    Dim SearchRange As Range
    Set SearchRange = ws.Range("A2:A" & ws.Cells(ws.Rows.count, 1).End(xlUp).Row)
    

    Dim FoundCell As Range, FirstCell As Range
    Dim i As Long
    For i = LBound(Master) To UBound(Master)
            Dim i2 As Long
            Dim myStr As String

            Set FoundCell = SearchRange.Find(What:=Master(i, 1))
            
            If FoundCell Is Nothing Then
                GoTo L1
            Else
                Set FirstCell = FoundCell
            End If
                    'FoundCell.Value = Master(i, 2)
                    
                    For i2 = 1 To Len(FoundCell.Value)
                        myStr = Mid(FoundCell.Value, i2, Len(Master(i, 1)))
                        If myStr Like Master(i, 1) Then
                            With FoundCell.Characters(Start:=i2, Length:=Len(Master(i, 1))).Font
                                .ColorIndex = 3
                            End With
                        End If
                    Next i2
                    If FoundCell.Offset(0, 1) = "" Then
                        FoundCell.Offset(0, 1) = Master(i, 2)
                    Else
                        FoundCell.Offset(0, 1) = FoundCell.Offset(0, 1).Value & "," & Master(i, 2)
                    End If
                    Master(i, 3) = Master(i, 3) + 1
                    Master(i, 4) = Date
                    
            Do
                Set FoundCell = SearchRange.FindNext(FoundCell)
                If FoundCell Is Nothing Then
                    GoTo L1
                ElseIf FoundCell.Address = FirstCell.Address Then
                    GoTo L1
                End If
                For i2 = 1 To Len(FoundCell.Value)
                        myStr = Mid(FoundCell.Value, i2, Len(Master(i, 1)))
                        If myStr Like Master(i, 1) Then
                            With FoundCell.Characters(Start:=i2, Length:=Len(Master(i, 1))).Font
                                .ColorIndex = 3
                            End With
                        End If
                    Next i2
                    
                    If FoundCell.Offset(0, 1) = "" Then
                        FoundCell.Offset(0, 1) = Master(i, 2)
                    Else
                        FoundCell.Offset(0, 1) = FoundCell.Offset(0, 1).Value & "," & Master(i, 2)
                    End If
                    Master(i, 3) = Master(i, 3) + 1
                    Master(i, 4) = Date
            Loop

L1:
    Next i
    
    'マスタの上書き
    wsm.Range(wsm.Cells(2, 1), wsm.Cells(lastRow, lastCol)).Value = Master
    
    MsgBox "チェック完了！"
    Application.ScreenUpdating = True
End Sub

ハッシュタグ

#excel #できること #vba #文字列検索 #データ処理 #特徴マスタ #配列操作 #条件付き書式 #Find関数 #データ管理 #自動化 #マクロ #Excel活用 #業務効率化 #エクセル #データ解析 #検索機能 #VBA初心者 #プログラミング #色変更

English Translation

Highlighting Registered Features in Red and Displaying Feature ID in Adjacent Column

This explanation is created using ChatGPT.

This VBA script searches for registered feature words from the "特徴マスタ" (Feature Master) sheet in column A of the active sheet,
highlights the matching words in red, and displays their corresponding Feature ID in the adjacent column (column B).
Additionally, it updates the detection count and the latest detection date in the "特徴マスタ" sheet.

How the Code Works

Retrieve Data from the "特徴マスタ" Sheet
- Saves the data from columns A (Feature Word) to D (Latest Detection Date) as an array.
Set the Search Range to Column A of the Active Sheet
- Defines column A (starting from row 2) as the search range.
Search for Each Feature Word in Column A
- Uses Find function to search for each feature word from the Feature Master in column A.
- If found, highlights the text in red (ColorIndex = 3).
- Writes the Feature ID in the adjacent cell (column B).
- Updates the detection count and the latest detection date in the "特徴マスタ" sheet.
Repeat the Process for Multiple Matches
- Uses FindNext to process all occurrences of the feature word in column A.
Update the "特徴マスタ" Sheet
- Saves the updated array back to the Feature Master sheet.
Display a Completion Message
- Shows MsgBox "チェック完了！" to indicate the process is finished.

Key Points

Uses arrays for fast data processing from the "特徴マスタ" sheet.
Uses "Find" and "FindNext" to locate multiple matches.
Highlights only the matched portion in red instead of coloring the entire cell.
Appends Feature ID to column B, adding "," if a value already exists.

Hashtags

#excel #automation #vba #stringsearch #dataprocessing #featuremaster #arrayoperations #conditionalformatting #findfunction #datamanagement #macro #exceluse #workefficiency #exceldata #dataanalysis #searchfunction #VBAforbeginners #programming #colorchange