VBAでhtmlソースから特定の文字列を抜き出す

こんにちは。
VBAの記述方法についてご質問です。
ご教示のほどよろしくお願いいたします。

◆やりたいこと
指定したURL(1000ページほどあります）にアクセスし、htmlソース内にちらばっている”スキー場名”を抽出しエクセルに値を返すVBAを記述したいです。

※スキー場名が記述されているタグはページごとに不規則なことが難点です。

◆やりたいことイメージ

画像内に記載しているURL

http://meito.knt.co.jp/detail.aspx?&crsno=1042176
http://meito.knt.co.jp/detail.aspx?&crsno=1061740
http://meito.knt.co.jp/detail.aspx?&crsno=1059072

No.3 回答者： WindFaller 回答日時： 2015/12/22 11:15

こんにちは。

一応、ご質問者さんの反応をお待ちしましたが、反応がないので、現在のものをそのままで掲示します。

'//
Dim ret As String
Sub Main()
Dim i As Long
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
　If Cells(i, 1).Value Like "http:*" Then
　　 Call DestGet(Cells(i, 1).Value)
　End If
　If ret <> "" Then
　　 Cells(i, 2).Value = ret
　End If
Next i
End Sub
Sub DestGet(strURL As String)
　　　　Dim objHTTP As Object
　　　　Dim httpLog As String
　　　　ret = ""
　　　　On Error GoTo ErrHandler
　　　　Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1") 'New winHttp.WinHttpRequest '
　　　　
　　　　objHTTP.Open "GET", strURL, False
　　　　objHTTP.Send
　　　　If objHTTP.Status = 200 Then
　　　　　　　　httpLog = objHTTP.ResponseText
　　　　　　　　ret = Analysislogs(httpLog)
　　　　Else
　　　　　　　　ret = " err"
　　　　End If
Exit Sub
ErrHandler:
End Sub
Function Analysislogs(httpLog As String)
　Dim arLog As Variant
　Dim oHtml As HTMLDocument
　Dim buf As Variant
　Dim tp, tpe, ct, ctt
　Dim i As Long
　Dim ar As Variant
　Dim dst As String
　Dim oRegExp As regExp
　Set oHtml = CreateObject("HTMLfile")
　oHtml.body.innerHTML = httpLog
　Set ct = oHtml.getElementById("content980")
　ctt = ct.innerText
　buf = ""
　Set oRegExp = New regExp
　Dim Matches
　Dim Match
　Dim arPat As Variant
　arPat = Array("[／「]([ぁ-んァ-ヶ・。！-～一-龠]+スキー場)」", "([ぁ-んァ-ヶ・。！-～一-龠]+スキー場)")
　For i = 0 To UBound(arPat)
　With oRegExp
　　　　 .Pattern = arPat(i)
　　　　 .Global = True
　　Set Matches = .Execute(ctt)
　　For Each Match In Matches
　　　　 If InStr(1, Match.SubMatches(0), buf, 1) > 1 Or buf = "" Then
　　　　　　 buf = Trim(buf) & "," & Match.SubMatches(0)
　　　　 End If
　　Next
　End With
　If buf <> "" Then
　　　　Exit For
　End If
　Next i
　If buf <> "" Then
　　 Analysislogs = Mid$(buf, 2)
　End If

End Function
'///

No.2 回答者： WindFaller 回答日時： 2015/12/19 19:53

こんばんは。

#1さん曰く
>スキー場の名前が決まった位置に出るわけではないので曖昧過ぎて拾えないでしょう。

そうなんですね、一応は、こちらは試してみて成功はしているものの、数多くやってみないとはっきりしたことは言えません。もうちょっと、いろんなバラエティのあるリストがほしいですね。
要するに、文字を拾うための様々なパターンを見極めないと無理かなって思うのです。今のところ、2パターンを用意しました。主に何を気にしているかというと、見落としがないか、文字列の中に入る記号にちょっと不安があるのです。

その見極めがつかないと、何度もやり直しになりそうで、ちょっと公開できません。それと、後々、あれがこうとか、これがこうしてほしいとか言われるのは、数が多そうなので、ちょっと辛いものがありますね。もし、ダメな時に、以前、延々とリクエストされたことがあり、とても懲りましたので、そこはご容赦願いたいものなのですが……。

とりあえず、添付画像をご覧ください。

No.1 回答者： keronjin 回答日時： 2015/12/18 18:47

スキー場の名前が決まった位置に出るわけではないので曖昧過ぎて拾えないでしょう。

国内のスキー場って4～500カ所あるんですかね、その一覧を用意して１つのシートにまとめておき、
ページ内に「スキー」の単語があったらその前5～6文字を拾いだし、
スキー場名一覧（シート）と部分比較してスキー場名を確定してはどうでしょうか。

具体的な手順としては、
●　Excel VBA の[ツール]-[参照設定]で、Microsoft Internet Control を参照設定しておく。
●　Ａ列のURLを取得。
●　URL指定したＩＥオブジェクトからHTMLソースを取得。
●　HTMLソース内を検索して「スキー」の単語があったらその前5～6文字を拾い出す。
●　拾い出した語句とスキー場名一覧を比較して部分一致したものをスキー場名として取得。
●　一致しない場合は再びそれ以降のソースから「スキー」の単語を検索。
●　Ｂ列に該当したスキー場名を記述。
●　改行してまたＡ列のURLを取得。以降URLが無くなるまで繰り返し。