Ｅｘｃｅｌ２０１０、ｈｔｍｌからタグを抽出する方法

Ｅｘｃｅｌ２０１０は、手頃な価格で高機能な表計算ソフトです。
またＶＢＡによるプログラムを行うと、特に繰り返し作業では多大な威力を発揮します。

一方、最近はＷｅｂサイトを構築して、情報発信を行う場合が増えてきました。
Ｗｅｂサイトは非常に有用ですが、構築した後の管理が大変になる場合が有ります。
Ｗｅｂサイトはｈｔｍｌファイルから成っており、この情報を把握できれば管理が容易になります。

そこで、エクセルでｈｔｍｌからタグを抽出する方法を検討しました。
使用したパソコンは、下記のソフトを使用していました。

ＯＳ　　　　　　　：　Ｗｉｎｄｏｗｓ７（６４ｂｉｔ）
表計算ソフト　　　：　Ｅｘｃｅｌ２０１０（３２ｂｉｔ）

以下、Ｅｘｃｅｌ２０１０、ｈｔｍｌからタグを抽出する方法を記載して行きます。

（項目１）
　・今回の目的は、エクセルＶＢＡで複数のｈｔｍｌファイルを開き、ページタイトル、キーワード、説明の情報
　　を取得して、一覧表を作る事に有ります。

（項目２）
　・本ページは、下記ＵＲＬを参照に作成しました。
　　T. Yoshiizumi - rubyによるExcel操縦あれこれ　〜　クエリテーブルの利用
　　Office TANAKA - Excel VBA Tips[正規表現によるマッチング]
　　■T'sWare Access Tips #319 〜２つの指定文字列で囲まれた部分を取り出すコード例〜

（項目３）
　・大きな流れは、下記の通りです。
　　ファイルを開く　→　データを転記　→　文字コードを変更　→　各要素を抽出　→　次のファイル

（項目４）
　・エクセルファイルは、ｈｔｍｌからタグを抽出する方法（公開用）をダウンロードして下さい。
　・使用方法は、以下の通りです。
　　上記ファイルと同じ場所に、ｈｔｍｌファイルをコピーする。
　　上記ファイルを起動する。
　　５行目に抽出したい要素の前半部分を記入する。
　　６行目に抽出したい要素の後半部分を記入する。
　　「検索実行」ボタンを押す。

（項目５）
　・各要素の抽出は、正規表現を使用しております。正規表現を使うには、以下のコードが必要です。
　　Set myReg = CreateObject("VBScript.RegExp")
　・例えば、タイトルの場合は、次の様になります。赤と赤の間の青を抽出します。
　　<title>@nifty</title>

（項目６）
　・全部のソースコードは、下記の通りです。

　　Option Explicit

　　'検索実行
　　Sub main()

　　　　'変数宣言
　　　　Dim i As Long
　　　　Dim j As Long
　　　　Dim OpenDirName As String
　　　　Dim OpenFileName As String
　　　　Dim code_moji As String
　　　　Dim code_kazu As Long

　　　　'変数設定
　　　　OpenDirName = ThisWorkbook.Path
　　　　OpenFileName = Dir(OpenDirName & "\*.htm", vbNormal) 'ｈｔｍ又はｈｔｍｌを開く

　　　　'ユーザーフォームを表示
　　　　UserForm1.StartUpPosition = 2
　　　　UserForm1.Show vbModeless
　　　　UserForm1.Repaint

　　　　'初期化
　　　　Range("C7:G1006").Select
　　　　Selection.ClearContents

　　　　'画面更新ＯＦＦ
　　　　Application.ScreenUpdating = False

　　　　'ファイルを開く
　　　　i = 1
　　　　Do While OpenFileName <> ""

　　　　　　Worksheets("作業用").Activate

　　　　　　'データを転記
　　　　　　Cells.Select
　　　　　　Selection.ClearContents

　　　　　　With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & OpenDirName & "\" & _
　　　　　　　　OpenFileName,Destination:=Range("$A$1"))
　　　　　　.Name = OpenFileName
　　　　　　.FieldNames = True
　　　　　　.RowNumbers = False
　　　　　　.FillAdjacentFormulas = False
　　　　　　.PreserveFormatting = True
　　　　　　.RefreshOnFileOpen = False
　　　　　　.RefreshStyle = xlInsertDeleteCells
　　　　　　.SavePassword = False
　　　　　　.SaveData = True
　　　　　　.AdjustColumnWidth = True
　　　　　　.RefreshPeriod = 0
　　　　　　.TextFilePromptOnRefresh = False
　　　　　　.TextFilePlatform = 1252
　　　　　　.TextFileStartRow = 1
　　　　　　.TextFileParseType = xlDelimited
　　　　　　.TextFileTextQualifier = xlTextQualifierDoubleQuote
　　　　　　.TextFileConsecutiveDelimiter = False
　　　　　　.TextFileTabDelimiter = True
　　　　　　.TextFileSemicolonDelimiter = False
　　　　　　.TextFileCommaDelimiter = False
　　　　　　.TextFileSpaceDelimiter = False
　　　　　　.TextFileColumnDataTypes = Array(1, 1)
　　　　　　.TextFileTrailingMinusNumbers = True
　　　　　　.Refresh BackgroundQuery:=False
　　　　　　End With

　　　　　　Cells.Select
　　　　　　Application.DisplayAlerts = False
　　　　　　Selection.QueryTable.Delete
　　　　　　Application.DisplayAlerts = True

　　　　　　'文字コードを変更
　　　　　　j = 1
　　　　　　code_moji = StrConv(search(j), vbUpperCase)

　　　　　　Select Case code_moji
　　　　　　　　Case "SHIFT_JIS"
　　　　　　　　　　code_kazu = 932
　　　　　　　　Case "UTF-8"
　　　　　　　　　　code_kazu = 65001
　　　　　　　　Case "EUC-JP"
　　　　　　　　　　code_kazu = 20932
　　　　　　　　Case "ASCII"
　　　　　　　　　　code_kazu = 1252
　　　　　　End Select

　　　　　　Cells.Select
　　　　　　Selection.ClearContents

　　　　　　With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & OpenDirName & "\" & _
　　　　　　　　OpenFileName,Destination:=Range("$A$1"))
　　　　　　.Name = OpenFileName
　　　　　　.FieldNames = True
　　　　　　.RowNumbers = False
　　　　　　.FillAdjacentFormulas = False
　　　　　　.PreserveFormatting = True
　　　　　　.RefreshOnFileOpen = False
　　　　　　.RefreshStyle = xlInsertDeleteCells
　　　　　　.SavePassword = False
　　　　　　.SaveData = True
　　　　　　.AdjustColumnWidth = True
　　　　　　.RefreshPeriod = 0
　　　　　　.TextFilePromptOnRefresh = False
　　　　　　.TextFilePlatform = code_kazu
　　　　　　.TextFileStartRow = 1
　　　　　　.TextFileParseType = xlDelimited
　　　　　　.TextFileTextQualifier = xlTextQualifierDoubleQuote
　　　　　　.TextFileConsecutiveDelimiter = False
　　　　　　.TextFileTabDelimiter = True
　　　　　　.TextFileSemicolonDelimiter = False
　　　　　　.TextFileCommaDelimiter = False
　　　　　　.TextFileSpaceDelimiter = False
　　　　　　.TextFileColumnDataTypes = Array(1, 1)
　　　　　　.TextFileTrailingMinusNumbers = True
　　　　　　.Refresh BackgroundQuery:=False
　　　　　　End With

　　　　　　Cells.Select
　　　　　　Application.DisplayAlerts = False
　　　　　　Selection.QueryTable.Delete
　　　　　　Application.DisplayAlerts = True

　　　　　　'列幅を戻す、Ａ１セルを選択
　　　　　　Selection.ColumnWidth = 8.38
　　　　　　Range("A1").Select

　　　　　　'ファイル名、文字コードを転記
　　　　　　Worksheets("メイン画面").Range("C" & i + 6) = OpenFileName

　　　　　　If code_moji = "" Then
　　　　　　　　Worksheets("メイン画面").Range("D" & i + 6) = "＊"
　　　　　　Else
　　　　　　　　Worksheets("メイン画面").Range("D" & i + 6) = code_moji
　　　　　　End If

　　　　　　'各要素を抽出
　　　　　　j = 2
　　　　　　Do Until Worksheets("メイン画面").Cells(5, j + 3) = ""

　　　　　　If search(j) = "" Then
　　　　　　　　Worksheets("メイン画面").Cells(i + 6, j + 3) = "＊"
　　　　　　Else
　　　　　　　　Worksheets("メイン画面").Cells(i + 6, j + 3) = search(j)
　　　　　　End If

　　　　　　j = j + 1

　　　　　　Loop

　　　　　　'次のファイル名を取得
　　　　　　OpenFileName = Dir

　　　　　　i = i + 1

　　　　Loop

　　　　Worksheets("メイン画面").Activate
　　　　Range("B4").Select

　　　　'画面更新ＯＮ
　　　　Application.ScreenUpdating = True

　　　　'ユーザーフォームを消去
　　　　Unload UserForm1

　　　　'終了処理
　　　　MsgBox ("検索が終了しました。")

　　End Sub

　　'各要素を調査
　　Function search(j As Long) As String

　　　　'変数宣言
　　　　Dim i As Long
　　　　Dim ichi1 As Long
　　　　Dim ichi2 As Long
　　　　Dim buf1 As String
　　　　Dim buf2 As String
　　　　Dim buf3 As String
　　　　Dim myStr1 As String
　　　　Dim myStr2 As String
　　　　Dim myReg As Object
　　　　Dim myPattern As String
　　　　Dim myRange As Range
　　　　Dim myMeta As Variant

　　　　'変数設定
　　　　Set myReg = CreateObject("VBScript.RegExp")
　　　　myMeta = Array("\", "^", "$", "?", "*", "+", ".", "|", "{", "}", "[", "]", "(", ")") '\を１番にする
　　　　buf1 = Worksheets("メイン画面").Cells(5, j + 3)
　　　　buf2 = Worksheets("メイン画面").Cells(6, j + 3)
　　　　myStr1 = buf1
　　　　myStr2 = buf2

　　　　'メタ文字処理
　　　　For i = 0 To 13
　　　　　　myStr1 = Replace(myStr1, myMeta(i), "\" & myMeta(i))
　　　　　　myStr2 = Replace(myStr2, myMeta(i), "\" & myMeta(i))
　　　　Next i

　　　　myPattern = myStr1 & ".*" & myStr2

　　　　'調査開始
　　　　With myReg
　　　　　　.Pattern = myPattern '検索パターンを設定
　　　　　　.IgnoreCase = True '大文字と小文字を区別しない
　　　　　　.Global = True '文字列全体を検索
　　　　　　For Each myRange In ActiveSheet.UsedRange
　　　　　　　　If Len(myRange) >= 256 Then
　　　　　　　　　　'何もしない
　　　　　　　　Else
　　　　　　　　　　If .Test(myRange.Formula) = True Then
　　　　　　　　　　　　'２つの指定文字列で囲まれた部分を取り出す
　　　　　　　　　　　　ichi1 = InStr(LCase(myRange.Formula), LCase(buf1)) + Len(buf1)
　　　　　　　　　　　　ichi2 = InStr(ichi1, LCase(myRange.Formula), LCase(buf2))
　　　　　　　　　　　　search = Mid$(myRange.Formula, ichi1, ichi2 - ichi1)
　　　　　　　　　　　　Exit For
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　Next myRange
　　　　End With

　　　　'終了処理
　　　　Set myReg = Nothing

　　End Function

（項目７）
　・以上で、Ｅｘｃｅｌ２０１０、ｈｔｍｌからタグを抽出する方法は終了です。