横長の表から指定したキーワードを含む情報を項目名と一緒にHTML表示する

2024年6月23日 17:05

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

このVBAプロシージャは、Excelシートから指定したキーワードを含む情報を検索し、その結果をHTML形式で表示するものです。以下に仕組みをわかりやすく説明します。

キーワード入力ボックスの表示:
- プロシージャが実行されると、まず最初にキーワードを入力するためのダイアログボックスが表示されます。このボックスに検索したいキーワードを入力します。
- キーワードが空白の場合は、警告メッセージが表示され、処理が終了します。
選択範囲の確認:
- 現在選択している範囲（セル）が1行のみであることを確認します。もし複数行が選択されている場合、警告メッセージを表示して処理を終了します。
データの取得:
- シートの1行目から項目名（ヘッダー）を取得します。
- 選択している行のデータを取得します。
キーワードの検索:
- 選択した行の各セルの値に対して、指定したキーワードが含まれているかをチェックします。
- キーワードが含まれているセルの項目名と値を別々のコレクションに保存します。
- キーワードが見つからない場合は、警告メッセージを表示して処理を終了します。
HTMLの生成:
- キーワードが含まれている項目名とデータをHTML形式に変換します。このとき、キーワードは赤字に変換されます。
HTMLファイルの作成と表示:
- 一時ファイルとしてHTMLを保存します。
- Microsoft Edgeを使用して、このHTMLファイルを開き、結果を表示します。

以下は、コードの主要部分を抜粋したものです。

Sub 横長の表から指定したキーワードを含む情報を項目名と一緒にHTML表示する()
    ' 検索するキーワードを入力する
    Dim keyword As String
    keyword = InputBox("検索するキーワードを入力してください:", "キーワード入力")
   
   ' キーワードがブランクならメッセージを表示
    If keyword = "" Then
        MsgBox "有効なキーワードを入力してください。", vbExclamation
        Exit Sub
    End If
   
    Dim ws As Worksheet
    Set ws = ThisWorkbook.ActiveSheet
    Dim rng As Range
    Set rng = Application.Selection
   ' カラム名の行を選択している場合はメッセージを表示して実行終了
    If rng.Rows.Count <> 1 Then
        MsgBox "一つのレコードを選択してください。", vbExclamation
        Exit Sub
    End If
   
    Dim headers As Variant
    headers = ws.Rows(1).Value ' 項目名をすべて取得
   
    Dim recordRow As Variant
    recordRow = ws.Rows(rng.Row).Value ' 選択中のレコードをすべて取得
   
    Dim found As Boolean
    found = False
    Dim foundHeaders As Collection
    Set foundHeaders = New Collection
    Dim foundRecords As Collection
    Set foundRecords = New Collection
   
    Dim i As Integer
    For i = LBound(recordRow, 2) To UBound(recordRow, 2)
        'エラー表示を別テキストに置換する
        Dim cellValue As String
        If IsError(recordRow(1, i)) Then
            cellValue = "　●エラー●　"
        Else
            cellValue = recordRow(1, i)
        End If
        ' キーワードを含む項目名とレコードを別の変数へ格納し、キーワードを赤字にするためにコードを追加
        If InStr(cellValue, keyword) > 0 Then
            found = True
            foundHeaders.Add headers(1, i)
            foundRecords.Add Replace(cellValue, keyword, "<span style='color:red;'>" & keyword & "</span>")
        End If
    Next i
   ' キーワードが含まれていない場合はメッセージを表示して実行終了する
    If Not found Then
        MsgBox "選択したレコードには「" & keyword & "」というキーワードが含まれていません。", vbExclamation
        Exit Sub
    End If
    
   ' 項目名とレコードを表示するためのHTMLを準備する
    Dim htmlOutput As String
    htmlOutput = "<html><body>"
   
    For i = 1 To foundHeaders.Count
        htmlOutput = htmlOutput & "<div><strong>" & foundHeaders(i) & "</strong></div>"
        htmlOutput = htmlOutput & "<div>" & foundRecords(i) & "</div><br>"
    Next i
   
    htmlOutput = htmlOutput & "</body></html>"
   
    ' 一時ファイルにHTMLを書き込む
    Dim tempFilePath As String
    tempFilePath = Environ$("temp") & "\temp.html"
    
    Dim fileNum As Integer
    fileNum = FreeFile
    Open tempFilePath For Output As fileNum
    Print #fileNum, htmlOutput
    Close fileNum
   
    ' Microsoft EdgeでHTMLファイルを開く
    Dim edgePath As String
    edgePath = """C:\Program Files (x86)\Microsoft\Edge\Application\msedge.exe"""
    
    Dim shellCommand As String
    shellCommand = edgePath & " " & tempFilePath
    Shell shellCommand, vbNormalFocus
End Sub

これで、指定したキーワードを含む情報を簡単にHTML形式で確認できます。

Excel VBA リファレンス | Microsoft Learn
この記事のYouTube動画はこちら

English Translation

Display information containing the specified keyword from a horizontally long table along with item names in HTML

This explanation is created using ChatGPT.

This VBA procedure searches for information containing a specified keyword from an Excel sheet and displays the results in HTML format. Here’s a breakdown of how it works.

Display Keyword Input Box:
- When the procedure is run, a dialog box for entering the keyword to search for is displayed. Enter the desired keyword in this box.
- If the keyword is blank, a warning message is displayed and the process ends.
Check Selected Range:
- The procedure checks if the currently selected range (cell) is only one row. If multiple rows are selected, a warning message is displayed and the process ends.
Retrieve Data:
- The procedure retrieves the item names (headers) from the first row of the sheet.
- It retrieves data from the selected row.
Search for Keyword:
- The procedure checks each cell value in the selected row for the specified keyword.
- It saves the item names and values of the cells containing the keyword into separate collections.
- If the keyword is not found, a warning message is displayed and the process ends.
Generate HTML:
- The procedure converts the item names and data containing the keyword into HTML format, highlighting the keyword in red.
Create and Display HTML File:
- The procedure saves the HTML as a temporary file.
- It opens the HTML file using Microsoft Edge, displaying the results.

Here is an excerpt of the main parts of the code.

Sub DisplayInfoWithKeywordFromWideTableInHTML()
    ' Enter the keyword to search
    Dim keyword As String
    keyword = InputBox("Please enter the keyword to search:", "Keyword Input")
   
    ' Display message if keyword is blank
    If keyword = "" Then
        MsgBox "Please enter a valid keyword.", vbExclamation
        Exit Sub
    End If
   
    Dim ws As Worksheet
    Set ws = ThisWorkbook.ActiveSheet
    Dim rng As Range
    Set rng = Application.Selection
    ' Display message and exit if a row of column names is selected
    If rng.Rows.Count <> 1 Then
        MsgBox "Please select a single record.", vbExclamation
        Exit Sub
    End If
   
    Dim headers As Variant
    headers = ws.Rows(1).Value ' Get all column names
   
    Dim recordRow As Variant
    recordRow = ws.Rows(rng.Row).Value ' Get all values of the selected record
   
    Dim found As Boolean
    found = False
    Dim foundHeaders As Collection
    Set foundHeaders = New Collection
    Dim foundRecords As Collection
    Set foundRecords = New Collection
   
    Dim i As Integer
    For i = LBound(recordRow, 2) To UBound(recordRow, 2)
        ' Replace error display with alternative text
        Dim cellValue As String
        If IsError(recordRow(1, i)) Then
            cellValue = "　●Error●　"
        Else
            cellValue = recordRow(1, i)
        End If
        ' Store the column name and record containing the keyword in another variable and add code to make the keyword red
        If InStr(cellValue, keyword) > 0 Then
            found = True
            foundHeaders.Add headers(1, i)
            foundRecords.Add Replace(cellValue, keyword, "<span style='color:red;'>" & keyword & "</span>")
        End If
    Next i
    ' Display message and exit if the keyword is not found
    If Not found Then
        MsgBox "The selected record does not contain the keyword "" & keyword & "".", vbExclamation
        Exit Sub
    End If
    
    ' Prepare HTML to display column names and records
    Dim htmlOutput As String
    htmlOutput = "<html><body>"
   
    For i = 1 To foundHeaders.Count
        htmlOutput = htmlOutput & "<div><strong>" & foundHeaders(i) & "</strong></div>"
        htmlOutput = htmlOutput & "<div>" & foundRecords(i) & "</div><br>"
    Next i
   
    htmlOutput = htmlOutput & "</body></html>"
   
    ' Write HTML to a temporary file
    Dim tempFilePath As String
    tempFilePath = Environ$("temp") & "\temp.html"
    
    Dim fileNum As Integer
    fileNum = FreeFile
    Open tempFilePath For Output As fileNum
    Print #fileNum, htmlOutput
    Close fileNum
   
    ' Open HTML file in Microsoft Edge
    Dim edgePath As String
    edgePath = """C:\Program Files (x86)\Microsoft\Edge\Application\msedge.exe"""
    
    Dim shellCommand As String
    shellCommand = edgePath & " " & tempFilePath
    Shell shellCommand, vbNormalFocus
End Sub

With this, you can easily check information containing the specified keyword in HTML format.

Excel VBA Reference | Microsoft Learn
Here is the YouTube video for this article

Hashtags:
#excel #できること #vba #キーワード検索 #HTML表示 #情報取得 #項目名 #レコード検索 #データ表示 #プロシージャ #ダイアログボックス #警告メッセージ #範囲選択 #データ取得 #検索結果 #エラー処理 #HTML生成 #一時ファイル #MicrosoftEdge #検索結果表示

この記事が気に入ったらサポートをしてみませんか？