本文へスキップ

別館:エクセルQC館 別館:エクセル株式館

  1. トップページ>
  2. Tips>
  3. Excel2010、htmlからタグを抽出する方法

Tipstips

備忘録として、主にパソコン関係のTipsを記載して行きます。


新着情報
@UiPath、メモ
AOffice365、Excel:VBAで画面更新がチラツク時の対策
BOffice365、Excel:勝手に手動計算になる原因
COffice365、Excel:フィルターで3つ以上の条件にする方法
DOffice365、Excel:シート同士の違いを見つける方法

Excel2010、htmlからタグを抽出する方法

Excel2010は、手頃な価格で高機能な表計算ソフトです。
またVBAによるプログラムを行うと、特に繰り返し作業では多大な威力を発揮します。

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

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

OS       : Windows7(64bit)
表計算ソフト   : Excel2010(32bit)

以下、Excel2010、htmlからタグを抽出する方法を記載して行きます。

(項目1)
 ・今回の目的は、エクセルVBAで複数のhtmlファイルを開き、ページタイトル、キーワード、説明の情報
  を取得して、一覧表を作る事に有ります。

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

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

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

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

(項目6)
 ・全部のソースコードは、下記の通りです。

  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) 'htm又はhtmlを開く

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

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

    '画面更新OFF
    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

      '列幅を戻す、A1セルを選択
      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

    '画面更新ON
    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("\", "^", "$", "?", "*", "+", ".", "|", "{", "}", "[", "]", "(", ")") '\を1番にする
    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
            '2つの指定文字列で囲まれた部分を取り出す
            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

(項目7)
 ・以上で、Excel2010、htmlからタグを抽出する方法は終了です。



contents

エクセル将棋館

日本国

地方都市


スポンサード リンク