人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

ExcelのVBAを使って取得したwebデータの切り出しについて。

ExcelでA2に「hello」と入れ、VBAで下記のようにしてアルクからhtmlソースを取得しました。

そのhtmlソースの中から、発音記号と意味を切り出してB2とC2へ入れるにはどのようなコードを書けば良いでしょうか?

A2セルの値→
hello

希望するB2のセルの中身→
helo'u

希望するC2セルの中身→
【間投】
やあ、こんにちは◆あいさつや呼び掛けとして用いられる。
もしもし◆電話での呼びかけや応答として用いられる。
【名】
helloという呼び掛け◆【複】hellos
【自動】
helloと言う[呼び掛ける]
【他動】
(人)にhelloと言う[呼び掛ける]


◆参考:アルクのサイト→
http://eow.alc.co.jp/search?q=hello


◆コード→
Sub getALC()
'Dim your variables
Dim url1 As String
Dim date1 As String
Dim http1 As Object
Dim start1 As Long
Dim length1 As Long

'Store the value in cell G2 earlier as length1
length1 = Sheet1.Range("G2").Value

For Each rcell In Sheet1.Range("A2:A2")
url1 = "http://eow.alc.co.jp/search?q="& rcell.Value
Set http1 = CreateObject("MSXML2.XMLHTTP")
http1.Open "GET", url1, False
http1.Send
text1 = http1.responseText
Sheet1.range("B2").value = ★発音記号★
Sheet1.range("C2").value = ★意味★

Next rcell

End Sub

●質問者: tetlis
●カテゴリ:インターネット ウェブ制作
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

1 ● うぃんど
●200ポイント

XMLに展開しようかとも思いましたが、
必要なのは極一部分なのでTEXTのままで処理させてみました

text1 = http1.responseText

' 大雑把な抜き出し
ps = InStr(text1, "<span class=""wordclass"">")
pe = InStr(ps, text1, "</div>")
text2 = Mid(text1, ps, pe - ps)

' タグ削除と整形
text2 = Replace(text2, "<span class=""wordclass"">", "")
text2 = Replace(text2, "</span>", "")
text2 = Replace(text2, "</li></ol>", vbLf)
text2 = Replace(text2, "<ol>", "")
text2 = Replace(text2, "</ol>", vbLf)
text2 = Replace(text2, "<li>", "")
text2 = Replace(text2, "</li>", vbLf)
text2 = Replace(text2, "<span class=""label"">", vbLf)
text2 = Replace(text2, "<span class=""pron"">", "")
text2 = Replace(text2, "◆" & vbLf, "◆")

' text2の確認用
' Debug.Print text2

' セルへの代入
Sheet1.Range("B2").Value = Split((Split(text2, "【発音】")(1)), "、")(0)
Sheet1.Range("C2").Value = Split(text2, vbLf & vbLf)(0)

以下の変数宣言も追加

Dim ps, pe As Long, text2 As String

tetlisさんのコメント
すぐにお返事いただきありがとうございました。

2 ● きゃづみぃ
●400ポイント

最初のG2の値を取得するのが 何なのかは よくわからないのですが
ある程度の単語に応対するように作ってみました。

単語によって使われてるタグが違うことがありますので
そのタグを取り除くために

 d = Replace(d, "<ol>", "")

というようなことを やっています。

残る場合は、これがある箇所に それを追加してください。

Sub getALC()
'Dim your variables
Dim url1 As String
Dim date1 As String
Dim http1 As Object
Dim start1 As Long
Dim length1 As Long

'Store the value in cell G2 earlier as length1
length1 = Sheet1.Range("G2").Value

For Each rcell In Sheet1.Range("A2:A5")
 url1 = "http://eow.alc.co.jp/search?q=" & rcell.Value
 Set http1 = CreateObject("MSXML2.XMLHTTP")
 http1.Open "GET", url1, False
 http1.Send
 text1 = http1.responseText
 
 Sheet1.Cells(rcell.Row, "B").Value = ""
 Sheet1.Cells(rcell.Row, "C").Value = ""
 
 c = "<span class=""wordclass"">"
 a = InStr(text1, c)
 If a = 0 Then Exit Sub
 
 text1 = Right(text1, Len(text1) - a - Len(c) + 1)
 
 b = InStr(text1, "【発音】")
 If b = 0 Then Exit Sub
 
 d = Left(text1, b - 1)
 
 d = Replace(d, "</span><ol><li>", vbCrLf)
 d = Replace(d, "<br />", vbCrLf)
 d = Replace(d, "</li><li>", vbCrLf)
 d = Replace(d, "</li>", "")
 d = Replace(d, "<ol>", "")
 d = Replace(d, "</ol>", "")
 d = Replace(d, "</span>", "")
 d = Replace(d, "<span class=""refvocab"">", "")
 d = Replace(d, "<span class=""label"">", "")
 d = Replace(d, "<span class=""kana"">", "")
 d = Replace(d, c, vbCrLf)
 
 c = "【発音】</span><span class=""pron"">"
 a = InStr(text1, c)
 
 If a = 0 Then Exit Sub
 text1 = Right(text1, Len(text1) - a - Len(c) + 1)
 
 a = InStr(text1, "<span class=""label"">")
 e = Left(text1, a - 1)
 e = Replace(e, "</span>", "")
 e = Replace(e, "<span class=""proni"">", "")
 Sheet1.Cells(rcell.Row, "B").Value = e
 Sheet1.Cells(rcell.Row, "C").Value = d

Next rcell

End Sub

tetlisさんのコメント
ありがとうございます。 他の人と違うアプローチの部分とループを参考にさせていただきます。

3 ● oil999
●700ポイント ベストアンサー

コメントいただいた、thump,merelyについても発音・意味を取得できるように修正しました。

以下のマクロをお試しください。
簡単なエラー処理も加えてあります。

Option Explicit

Sub getALC()
 Dim url As String, word As String, html As String
 Dim http As Object
 Dim arr() As String, sense As String, pronun As String
 Dim i As Long

 word = Sheet1.Range("A2:A2").Value
 url = "http://eow.alc.co.jp/search?q=" & word
 Set http = CreateObject("MSXML2.XMLHTTP")
 http.Open "GET", url, False
 http.Send
 html = http.responseText
 arr = Split(html, vbCrLf)
 i = toSense(word, arr)
 If (i > 0) Then
 pronun = getPronun(arr(i))
 If (pronun = "") Then pronun = "★発音が見当たりません"
 sense = getSense(arr(i))
 If (sense = "") Then sense = "★意味が見当たりません"
 Else
 pronun = "★発音が見当たりません"
 sense = "★意味が見当たりません"
 End If
 Sheet1.Range("B2").Value = pronun
 Sheet1.Range("C2").Value = sense
End Sub

'意味が記述されている行番号を取り出す
Function toSense(word As String, arr() As String) As Long
 Dim i As Integer, n As Integer
 Dim re As Object
 Dim flag As Boolean
 Set re = CreateObject("VBScript.RegExp")
 
 n = UBound(arr)
  '探索
 With re
 .Pattern = "<font class='searchwordfont' color='#BF0000'>" & word & "</font>"
 .IgnoreCase = True
 .Global = True
 flag = False
 i = 0
 While (i <= n And flag = False)
 If .test(arr(i)) Then flag = True
 i = i + 1
 Wend
 End With
 If (flag = True) Then
 toSense = i
 With re
 .Pattern = "<span class=""wordclass"">"
 .IgnoreCase = True
 .Global = True
 flag = False
 If .test(arr(toSense - 1)) Then toSense = toSense - 1
 End With
 Else
 toSense = 0
 End If
 Set re = Nothing

End Function

'意味のHTML文をプレーンテキストに加工
Function getSense(sour As String) As String
 Dim re As Object
 Dim remat
 
 getSense = ""
 Set re = CreateObject("VBScript.RegExp")
  '意味部分の抽出
 With re
 .Pattern = "<span class=""wordclass"">(.+)(<span class=""label"">【レベル】).+"
 .IgnoreCase = True
 .Global = True
 Set remat = .Execute(sour)
 If remat.Count > 0 Then
 getSense = remat(0).submatches(0)
 End If
 End With
  'プレーンテキストに変換
 With re
 .Pattern = "</li></ol>|<ol>|</li>|</ol>"
 .IgnoreCase = True
 .Global = True
 getSense = .Replace(getSense, vbCrLf)
 End With
 With re
 .Pattern = "<[0-9a-z/\=""' #]+>"
 .IgnoreCase = True
 .Global = True
 getSense = .Replace(getSense, "")
 End With
 Set re = Nothing
End Function

'発音のHTML文をプレーンテキストに加工
Function getPronun(sour As String) As String
 Dim re As Object
 Dim remat
 
 getPronun = ""
 Set re = CreateObject("VBScript.RegExp")
  '発音部分の抽出
 With re
 .Pattern = "<span class=""pron"">([^、]+)、</span>"
 .IgnoreCase = True
 .Global = True
 Set remat = .Execute(sour)
 If remat.Count > 0 Then
 getPronun = remat(0).submatches(0)
 End If
 End With
  'プレーンテキストに変換
 With re
 .Pattern = "<[0-9a-z/\=""' #]+>"
 .IgnoreCase = True
 .Global = True
 getPronun = .Replace(getPronun, "")
 End With
 
 Set re = Nothing
End Function

tetlisさんのコメント
素敵な回答ありがとうございます。 ところで、 「thump」だと、発音が「★発音が見当たりません」で意味が空欄。 「merely」を入れると意味は正しいのですが、発音が「mi'?<span class="proni">r</span>li」 となってしまうのですが、どうしたら解決できますでしょうか?

oil999さんのコメント
コメントいただいた、thump,merelyについても発音・意味を取得できるように修正しました。 お試しください。

tetlisさんのコメント
出来ました! 他にも応用がききそうです。ありがとうございました。
関連質問

●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ