URLから特定箇所のHTMLを抽出して文字数をカウントするマクロ

2018年7月3日

すごい久しぶりにブログを書きます。あんまりWEBの事と関係ないけど、とある案件で翻訳の見積を作成する際にさすがに人力はきついというか日が暮れるなと思ったのでマクロを探しました。

用途

今回はページ数は数百ページあり明日までに見積がほしいと夕方頃に言われたので急遽調べました…。

サイトの多言語サイトの見積でコンテンツ部分の日本語文字数をカウントするという用途でのマクロです。

マクロ

Public Sub StringsCount()
Dim url As Range
Dim Http, buf As String
Dim re, mc
Set Http = CreateObject("MSXML2.XMLHTTP")
Set re = CreateObject("VBScript.RegExp")
Set url = Range("A2")
Do While (url.Value <> "")
Http.Open "GET", url.Value, False
Http.Send
With CreateObject("ADODB.Stream")
.Open
.Type = 2 'adTypeText
.Charset = "unicode"
.Writetext Http.ResponseBody
.Position = 0
.Charset = "utf-8"
buf = .ReadText()
.Close
End With
With re
.IgnoreCase = True
.Global = True
'ダブルクオーテーションをエスケープする時は""文字列""とする。
.Pattern = "<article.*?>([\s\S]*?)</article>"
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 1) = mc(0).SubMatches(0)
End With
Set url = url.Offset(1, 0)
Loop
Set Http = Nothing
Set re = Nothing
End Sub

説明

簡単に説明するとエクセルのA列にURLを入れます。URLのHTML内のarticleタグの中身をB列に抽出します。マクロの内容はここまでですが、エクセルのほうでC列に関数でB列の全角/半角の文字数-半角の文字数を入れておきます。関数は=LENB(B2)-LEN(B2)みたいな感じ。するとタグやスクリプトといった半角英数字が除外されて全角の日本語本文のみの文字数をカウントできます。

手作業でテキスト抜いてWordなんかでカウントすると多分1日仕事ですがマクロなら数分といった所です。