プロが教えるわが家の防犯対策術!

現在、卒業論文としてことわざの使用頻度を調べる研究をしています。

具体的には、国立国語研究所の少納言という検索エンジンで、自動的に検索結果をエクセルに保存するプログラムを作っているところです。

「エクセルに保存してある値を検索して、結果をとなりの列に記入する」というプログラムを動かしたいのですが、上手く動きません。どなたか解決方法をご存知でしたら、教えてください。

具体的には、
エクセルのA列の2行目から4行目まで、ことわざを入力しているテストファイルがあります。セル(i, 1)にある値を取り出して、制御中のIEの検索フォームに入力して、検索結果(約○○件のところ)をセル(i, 2)に入力する。これを4回ループするプログラムを作成しています。

しかし、4つの問題点があって安定して作動しません。
1. 検索前のページのHTMLドキュメントを取得してしまう場合がある。
2. その場合、ループの最後の方にあるie.Quitが作動しない。
3. そもそも、HTMLドキュメントが取得されずに、セル(i, 2)が空欄のままになる場合がある。
4. IEのページ移動待ちでプログラムが止まってしまう

ただし、これらの症状はステップインで一行ずつ動かした場合は発生しませんが、VBAでそのまま動かすと発生する場合としない場合があります。
申し訳ありませんが、どなたかよろしくお願いします。

Option Explicit
'ワークシートの開始行設定
Private Const ROW_START As Long = 2
Private Const COL_KOTOWAZA As Long = 1
Private Const COL_FREQUENCY As Long = 2

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Function waitBrowsing(ie As InternetExplorer)
Do While ie.Busy Or ie.ReadyState < READYSTATE_COMPLETE
DoEvents ‘この移動待ちのDoEventsで止まってしまうときがあります。
Loop
End Function

Private Sub getKotoFreq()
Dim sht As Worksheet
Set sht = ActiveSheet
Dim i As Long
i = ROW_START

Do While i < 5
'少納言を新しいIEウィンドウで開く
Dim ie As InternetExplorer
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = True
ie.Navigate "http://www.kotonoha.gr.jp/shonagon/search_form"

‘とりあえすスリープはたくさん取っています。
waitBrowsing ie
Sleep 10000

'検索フォームにシートのセル(i, 1)の値を入力
Dim cellkoto As String
cellkoto = sht.Cells(i, COL_KOTOWAZA).Value
Let ie.document.getElementById("query_string").Value = cellkoto
Sleep 5000

'フォームを送信
Dim form As HTMLFormElement
Set form = ie.document.forms("search_form")
form.submit

waitBrowsing ie
Sleep 10000

'HTMLドキュメントの取得
Dim objTAG As Object
Dim strTNAME As String
Dim flag As Integer
flag = 0

‘このFor Each…Nextはおそらく問題ありません。
For Each objTAG In ie.document.all
strTNAME = objTAG.tagName
If flag = 0 Then
If strTNAME = "P" Then
sht.Cells(i, 3).Value = objTAG.innerText
flag = 1
End If
ElseIf flag = 1 Then
'なにもしない
End If
Next

Sleep 3000
'IEを閉じる。前ページのHTMLドキュメントを読み込んだ時は、実行されない
ie.Quit
Sleep 3000
Set ie = Nothing
Set objTAG = Nothing
Sleep 1000

'エクセル上書き保存
ThisWorkbook.Save
i = i + 1
Loop

MsgBox "プログラムは終了しました."
End Sub

A 回答 (1件)

こんにちは。

私も試しにやってみました。

質問者さんのマクロコードは、完全、ロボット化を目指すもののようですが、そこまでしなくてはいけないのでしょうか。

私の提案としては、
基本的には、IEの起動からですが、以下のマクロなら途中からでも、横取りして稼働します。'form' や 'result' 画面からでも、出来ます。したがって、ホームページの下の「利用条件を読んで少納言を使う」という部分の処理は、中途半端で確認していません。検索画面から直接可能です。なお、検索結果のテーブル項目の1つが落ちてしまうので、あえて、こちらで入れるようにしました。

コードを換えれば、複数の検索文字列に代入出来るますが、私自身では、今のところは考えていません。

'//
'Option Explicit
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)

Sub IEGetWords()
 Const BASEURL As String = "http://www.kotonoha.gr.jp/shonagon/" 'search_form"
 Dim num As Variant
 Dim w As Object
 Dim Keyword As String
 Dim objIE As InternetExplorer
 Dim objShellWin As Object
 Dim encText As String
 Dim dl, qs, sf, hdb, tb
 Dim buf As Variant, buft As Variant
 Dim ieflg As Boolean
 Dim i As Long, n As Variant, k As Long
 Dim arbuf As Variant
 Dim Matches As Object, Match As Variant
 On Error GoTo BeforeQuit
 Set objIE = New InternetExplorer
 Keyword = ActiveSheet.Cells(1, 3).Value
 If Len(Keyword) < 2 Then
  MsgBox "検索語を、C1に入れてください。", vbExclamation
  Exit Sub
 End If
 Set objShellWin = CreateObject("Shell.Application").Windows()
 For Each w In objShellWin
  If TypeName(w) = "IWebBrowser2" Then
   If InStr(1, w.LocationURL, "shonagon", 1) > 0 Then
    Set objIE = w
    Exit For
   End If
  End If
 Next
 With objIE
  If InStr(1, objIE.LocationURL, "shonagon", 1) = 0 Then
   .Visible = True
   .Navigate2 BASEURL
    Do Until Not .Busy And .ReadyState = 4: DoEvents: Loop
  End If
    .Visible = True
ReStart:
    Sleep 1000
    .Navigate2 BASEURL & "search_form"
     Do Until Not .Busy And .ReadyState = 4: DoEvents: Loop
    If InStr(1, .LocationURL, "search_form", 1) = 0 Then
    Set dl = .Document.getElementById("dialog-link")
    dl.Click
    Sleep 1000
    GoTo ReStart
    End If
   
   'Set dlg = .Document.getElementById("dialog")
   'Set dlbtn = .Document.getElementsByClass("ui-button ui-widget ui-state-default ui-corner-all ui-button-text-only")
   'dlg.Click
   'End If
  End With
  With objIE
   Set qs = .Document.getElementById("query_string")
   If Not qs Is Nothing Then
    qs.Value = Keyword
    Else
   
   End If
   Sleep 1000
   Set sf = .Document.getElementById("search_form")
   sf.Submit
   Do Until Not .Busy And .ReadyState = 4: DoEvents: Loop
   Sleep 1000
   Set hdb = .Document.getElementById("headerB")
   If IsObject(hdb) Then
     buf = LTrim(Replace(hdb.innerText, "検索結果", ""))
     If Val(buf) = 0 Then
      MsgBox "検索結果は、0でした。", vbExclamation
      GoTo BeforeQuit
     End If
   End If
   If InStr(1, .LocationURL, "result", 1) = 0 Then
    MsgBox "画面が切り替わりません。"
    GoTo BeforeQuit
   End If
    On Error Resume Next
    Set tb = .Document.getElementById("tablekit-table-1")
    On Error Resume Next
   If Not IsObject(tb) Then
    MsgBox "取得に失敗しました。", vbExclamation
    GoTo BeforeQuit
   End If
   End With
   With CreateObject("VBScript.RegExp")
    .Pattern = "<td[^>]+>([^<]*)</td>"
    .Global = True
    .IgnoreCase = False
    Cells(1, 1).Value = buf
    i = 2
    
    For Each n In tb.Rows
    Application.ScreenUpdating = False '全体にすると、ハングしたように見える
     If i = 2 Then
      buf = "表示番号,前文脈,検索文字列,後文脈,執筆者,生年代,性別,メディア/ジャンル,タイトル,副題,巻号,編著者等*,出版者,出版年"
      arbuf = Split(buf, ",")
      Cells(i, 1).Resize(, 14).Value = arbuf
      buf = ""
     Else
      buf = n.innerHTML
     Set Matches = .Execute(buf)
     For Each Match In Matches
      buft = buft & "," & Match.SubMatches(0)
     Next
     buft = Mid(buft, 2)
     arbuf = Split(buft, ",")
     For k = 0 To UBound(arbuf)
      Cells(i, k + 1).Value = arbuf(k)
     Next
     buft = ""
     Sleep 500
     DoEvents
     End If
     i = i + 1
     Application.ScreenUpdating = True
    Next
   End With

BeforeQuit:
   If Err() <> 0 Then
     MsgBox Err.Number & ": " & Err.Description
   Else
     MsgBox "正常終了しました。", vbInformation
   End If
   Set objIE = Nothing
End Sub
'///
----
    • good
    • 0

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!