現在、卒業論文としてことわざの使用頻度を調べる研究をしています。
具体的には、国立国語研究所の少納言という検索エンジンで、自動的に検索結果をエクセルに保存するプログラムを作っているところです。
「エクセルに保存してある値を検索して、結果をとなりの列に記入する」というプログラムを動かしたいのですが、上手く動きません。どなたか解決方法をご存知でしたら、教えてください。
具体的には、
エクセルの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件)
- 最新から表示
- 回答順に表示
No.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
'///
----
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) VBAが止まります。 2 2022/09/02 14:02
- Visual Basic(VBA) いつもお世話になっております、VBAで教えて頂きたいのですが 2 2022/05/05 22:20
- Visual Basic(VBA) 貼り付けた値が消えていく 以下はソースファイルの2番目のシートのB6から最終行を取得 ターゲットファ 2 2023/07/27 12:23
- Excel(エクセル) 日付で矢印マクロ 4 2023/07/25 16:47
- Visual Basic(VBA) VBA処理追加 こちらでご教示頂いたのですが回答完了させてしまいましたのでこちらからまた質問させてく 2 2022/10/27 09:57
- Visual Basic(VBA) このVBAでExcelアプリケーションを作成は必要ですか? 3 2023/07/19 21:13
- Visual Basic(VBA) 別シートから年齢別の件数をカウントしたいの続き 5 2023/01/24 00:16
- Excel(エクセル) VBAの指示の内容 昨日こちらでご教示頂いたのですが初心者な為、一つ一つの指示が何をやっているのかわ 2 2022/10/25 18:08
- Visual Basic(VBA) EXCEL VBAにて動的にCheckBOXを複数作成し、同BOXにイベントを追加したい 1 2023/03/16 07:05
- Excel(エクセル) フォルダ内のワードファイルをPDFに一括変換するVBA 3 2023/06/09 16:51
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
Windowsのアプリ開発ってなんの...
-
Webプログラムってネイティブア...
-
スカラーのベクトル微分
-
vba クリップボードクリアにつ...
-
IT業界より楽に稼げる業界って...
-
フリーランスのエンジニアって...
-
ハッシュテーブル(連想配列)が...
-
pythonにてseleniumを使うも、...
-
Google ColaboでGUI作成
-
ものづくりに向いているプログ...
-
そのまま使っただけなのに・・...
-
Selenium4でボタンをクリックで...
-
Pythonでターミナルに文字を出...
-
HTMLソースが表示のページのも...
-
プログラムの起動、利用につい...
-
Windowsのバッチファイルについ...
-
このURLで広告を出しているのは...
-
バッチファイルについて
-
昔のパソコン少年の武勇伝「店...
-
matplotlibで任意の角度の円弧...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
ページソースからのURL抽出
-
AJAXを使用したサイトに対するg...
-
htmlelementからinternet explo...
-
VBA シートのボタン名を変更し...
-
ユーザーフォームを表示中にシ...
-
VBA(エクセル)で自動的にボタン...
-
worksheetFunctionクラスのVloo...
-
実行時エラー 438になった時の...
-
「Columns("A:C")」の列文字を...
-
エクセルエラー13型が一致しま...
-
eclipseのデバッグ中に変数の値...
-
ウォッチ式の文字数制限について
-
【C#/Java?】try-catchでcatch...
-
ユーザーフォームのテキストボ...
-
カメラスクロールするのを動画...
-
Microsoft Formsの「個人情報や...
-
IF文に時間(何時から何時ま...
-
エクセル・VBA CheckBoxのオブ...
-
全てのオブジェクトのプロパテ...
-
【Excel VBA】マクロをボタンに...
おすすめ情報