【Excel】Webページからデータ抽出【ＶＢＡ】

質問

面倒な作業を一括して出来るようにしたく、
質問させて頂きました。

VBAで実行したい項目を挙げます。
１．特定のWebページを開く
２．日付を取得する
３．指定した日付の行を取得する
４．行のタイトル（文章）と、リンクのURLを取得する
５．指定した日付（10月1日～10月20日まで）などの
　　データを（タイトルとリンク）Excel上に記入

以下の図のような感じです。
Ｗｅｂページは個人的なものなので
教えることが出来ないため、
このような図で申し訳ないです。

また、必要な情報（足りない情報）がありましたら
追加しますので、よろしくお願い致します。

回答No.5

jA6uDWNL · ベストアンサー

例えば、ページのタイトルの違いで分岐させる方法があると思います。ie.document.titleで参照できます。
ようは、htmlにこの情報が入っていればログインページであると判断すればいいのです。

[処理の流れ]
データ取得ページへアクセス
↓
情報取得待ち
↓
タイトルに"ログイン"(例えば)が入っている時のみ、ログイン処理を行う
↓
ログイン処理をした時は情報取得待ち
↓
データ取得ページから情報取得＆エクセル出力

ページ遷移するときは常に
Do While ie.Busy Or ie.readyState <> 4
DoEvents
Loop

Do While ie.document.readyState <> "complete"
DoEvents
Loop
のような情報取得待ちのコードを入れるようにしてください。

お礼

追記します。
だいぶ出来てきたのですが、
あと一つだけ問題があります。
IEのバージョンが9ということです。

9だからか、エラーが多発し
上手く開けるときと開けないときがあります。
全部IE閉じてからじゃないと上手くいかず
閉じても上手くいかないこともあり、困ってます・・・

回答よろしくお願い致します！

補足

何度も回答ありがとうございます！
ページタイトルを確認してみたところ、
ログインページも、ログイン後のページも同じでした。
こうなったら、ログインボタンあるかの判断でもいいですかね・・・？

回答No.4

jA6uDWNL

エラーになっていないのであれば、書き込めていると思います。

[Sheets(writeSheet).Cells(cnt, 1).Value = dt]の直前で
writeSheet、cnt、dtの値を確認して下さい。

writeSheet => Sheet1、
cnt => 1、
dt => 10/18

となっている場合は現在アクティブなワークブックの[Sheet1]シートの[A1]に[10/18]が入ります。
[Sheets("Sheet1").Cells(1, 1).Value = "10/18"]
と同等の意味です。

ワークブックを複数開いている場合、ちがうワークブックに書き込まれている可能性があります。
書き込むブックを指定したい場合は、
[Workbooks("Book1.xlsm").Sheets("Sheet1").Cells(1, 1).Value = "10/18"]
のようにして指定できます。

補足

回答ありがとうございます。
おかげさまで、だいぶ出来るようになりました！

教えて頂いたプログラムと、Webを参考に
下記プログラムでログインし、データを取得することができました。

Sub ie_test()

Dim ie As Object

webUrl = "http:// '←接続先URL

Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = False
ie.Navigate2 webUrl

Do While ie.Busy Or ie.readyState <> 4
DoEvents
Loop

ie.Visible = True

Workbooks("WorkBookの名前").Activate
Worksheets("シート名").Activate
ID = InputBox(prompt:="IDを入力してください", _
title:="ナレッジ　ID", Default:="")
Password = InputBox(prompt:="Passwordを入力してください", _
title:="ナレッジ　Password", Default:="")

ie.document.all.uname.Value = ID 'ID
ie.document.all.pass.Value = Password 'パスワード

'INPUTのタグを集める .getElementsByTagName("INPUT")を使用
Set objINPUT = ie.document.getElementsByTagName("INPUT")

'ループで頭からテキストがログインを探す
For n = 0 To objINPUT.Length - 1
'※ type="submitボタンなので、.InnerTextじゃなくて、.Valueです ※※注意
If InStr(objINPUT(n).Value, "ログイン") > 0 Then '文字列の中から見つけたら
MsgBox "見つけました"
objINPUT(n).Click '見つけたINPUTタグのオブジェクトをクリック
Exit For
End If
Next

Set objINPUT = Nothing 'オブジェクト変数解放
End Sub

しかし、初回起動時（パソコン再起動、起動時）
だけログインをしないといけないみたいです。
パソコン起動後に一回ログインしていれば
ページが表示されるらしいのですが、
初回起動時なのかどうか判断することができません。

初回でない場合は、勝手にログイン後の
ページになっています（URLは同じです）

エラーが出たら、そのマクロへ飛ばすように
組めば良いでしょうか？

jA6uDWNL様のおかげで、どのようにプログラムを組めばよいのか分かってきて、あともう少しで完成します。

回答No.3

jA6uDWNL

Public Sub データ抽出()
Dim webUrl As String
Dim writeSheet As String
Dim srchDt As String

webUrl = "http://" '←接続先URL
writeSheet = "Sheet1" '←書き込み先シート名
srchDt = "10/18" '←指定日付
'srchDt = Sheets("Sheet2").Range("A1").Value 'たとえばSheets2のA1セルの値で日付を指定する場合

Dim ie As Object
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = False
ie.Navigate2 webUrl

Do While ie.Busy Or ie.readyState <> 4
DoEvents
Loop

Dim doc As Object
Set doc = ie.document
Do While doc.readyState <> "complete"
DoEvents
Loop

Dim dt As String
Dim title As String
Dim url As String
Dim cnt As Long

Dim tr As Object
Dim tds As Object
For Each tr In doc.getElementsByTagName("table")(0).getElementsByTagName("tr")
Set tds = tr.getElementsByTagName("td")
If tds.Length > 0 Then
'日付、タイトル、URL取得
dt = Format(Trim(tds(1).innerText), "mm/dd")
title = Trim(tds(4).innerText)
url = Trim(tds(4).getElementsByTagName("a")(0).getAttribute("href"))

If dt = srchDt Then
'エクセルに書き込み
cnt = cnt + 1
Sheets(writeSheet).Cells(cnt, 1).Value = dt
Sheets(writeSheet).Cells(cnt, 2).Value = title
Sheets(writeSheet).Cells(cnt, 3).Value = url
End If
End If
Next

ie.Quit

End Sub

JavaScript関連でエラーになっているかもと思ったので、すこしコードを変えました。
内部でIEを使っています。エラーになった場合、IEのプロセスが残ってしまうので注意してください。
おそらく動くと思うのですが、エラーになってしまった場合は、エラーメッセージとエラー箇所を教えて下さい。

お礼

すみません、補足がまだありましたので、回答お願い致します。

For Each tr In doc.getElementsByTagName("table")(3).getElementsByTagName("tr")

Set tds = tr.getElementsByTagName("td")
If tds.Length > 0 Then
'日付、タイトル、URL取得
dt = Format(Trim(tds(1).innerText), "yy/mm/dd")
title = Trim(tds(6).innerText)
url = Trim(tds(6).getElementsByTagName("a")(0).getAttribute("href"))

If dt = srchDt Then
'エクセルに書き込み
EndLine = EndCheck()

'MsgBox dt & title & url & EndLine '最終行

'Range("A1") = dt
'Cells(i, 2) = title
'Cells(i, 3) = url
Sheets(writeSheet).Cells(EndLine, 1).Value = "TOPICS"
Sheets(writeSheet).Cells(EndLine, 2).Value = dt
Sheets(writeSheet).Cells(EndLine, 3).Value = title
'url = ie.LocationURL & url

Sheets(writeSheet).Cells(EndLine, 4).Value = "http://192.168.230.158/modules/faq/" & url

End If
End If
Next

の部分ですが、
これを何回も検索しなければならず、ものすごく重いため、

コンボボックスで選択した日時を
下回ったら終了
みたいにできないでしょうか？

よろしくお願い致します。

補足

何度も、本当にありがとうございます！

一つ、重要なことに気づきました。
サイトを新しく開くところまでのみをやってみたのですが、
開きたいページではなく、
開きたいページの一歩手前のログイン画面になってしまいます。
もしかしたらこれが原因かもしれません。

ログインできないか方法を調べ、VBA実行したところ、
原因は良くわかりませんが、ログインすることができました。

なぜか、1回実行すれば良いみたいで、
2回目（プログラムを訂正してから）なども
ログインしようとするとログイン後の画面になっており
エラーが出てしまいます。
サーバーにあるHTML?　ホームページ？のため、
複雑なのかもしれません。

色々改変を加えた結果、動くようになりましたが、
EXCELファイルに結果が書き込まれません。

[cnt=cnt+1]の後に
MsgBox dt & title & url
というのを加えて、実際にデータがあるかを調べてみたのですが、
メッセージボックスにはしっかりデータが入力されています。

何度も本当に申し訳ないのですが、回答よろしくお願いいたします。

回答No.2

jA6uDWNL

Public Sub データ抽出()
Dim webUrl As String
Dim writeSheet As String
Dim srchDt As String

webUrl = "http://" '←接続先URL
writeSheet = "Sheet1" '←書き込み先シート名
srchDt = "10/18" '←指定日付
'srchDt = Sheets("Sheet2").Range("A1").Value 'たとえばSheets2のA1セルの値で日付を指定する場合

Dim htm As New MSHTML.HTMLDocument
Dim doc As MSHTML.HTMLDocument
Set doc = htm.createDocumentFromUrl(webUrl, vbNullString)

Do While doc.readyState <> "complete"
DoEvents
Loop

Dim dt As String
Dim title As String
Dim url As String
Dim cnt As Long

Dim tr As Object
Dim tds As Object
For Each tr In doc.getElementsByTagName("table")(0).getElementsByTagName("tr")
Set tds = tr.getElementsByTagName("td")
If tds.Length > 0 Then
'日付、タイトル、URL取得
dt = Format(Trim(tds(1).innerText), "mm/dd")
title = Trim(tds(4).innerText)
url = Trim(tds(4).getElementsByTagName("a")(0).getAttribute("href"))

If dt = srchDt Then
'エクセルに書き込み
cnt = cnt + 1
Sheets(writeSheet).Cells(cnt, 1).Value = dt
Sheets(writeSheet).Cells(cnt, 2).Value = title
Sheets(writeSheet).Cells(cnt, 3).Value = url
End If
End If
Next
End Sub

補足いただいたソースで実験して私の環境では動きました。

説明し忘れていましたが、参照設定をしないとこのコードは動きません。
VBEの[ツール][参照設定]で[Microsoft HTML Object Library]にチェックを入れてください。

あと、
For Each tr In doc.getElementsByTagName("table")(0).getElementsByTagName("tr")
の部分の(0)は１つ目のテーブルという意味です。
もし、データが入っているTableが２つ目のTableなら(1)、３つ目のTableなら(2)になります。

補足

回答ありがとうございます！
とても分かりやすく、有難いです。

しかし、またも私の勘違いがありました。
サイトのソースを確認したところ、

最後のくくりが＜/html＞だったため、勘違いしていまいました。
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" >
ソースの一番上にこれが書いてありました。
ソースの途中にはtype="text/css"というのもあります。
問題ないでしょうか？

何度も申し訳ありません。

For Each tr In doc.getElementsByTagName("table")(0).getElementsByTagName("tr")
そのせいか、この部分でエラーが出ます。
教えて頂いたとおり、VBEの[ツール][参照設定]で[Microsoft HTML Object Library]にチェックを入れました。

何度も、本当に申し訳ないのですが、回答いただけるとうれしいです。

回答No.1

jA6uDWNL

考えました。
抽出対象のWebページのデータ部分はTableであると仮定して作りました。
間違ってたらすいません。

以下のプロシージャをボタンにマクロ登録するなどして実行してください。

Public Sub データ抽出()
Dim webUrl As String
Dim writeSheet As String
Dim srchDt As String

webUrl = "http://" '←接続先URL
writeSheet = "Sheet1" '←書き込み先シート名
srchDt = "09/05" '←指定日付
'srchDt = Sheets("Sheet2").Range("A1").Value 'たとえばSheets2のA1セルの値で日付を指定する場合

Dim htm As New MSHTML.HTMLDocument
Dim doc As MSHTML.HTMLDocument
Set doc = htm.createDocumentFromUrl(webUrl, vbNullString)

Do While doc.readyState <> "complete"
DoEvents
Loop

Dim dt As String
Dim title As String
Dim url As String
Dim cnt As Long

Dim tr As Object
Dim tds As Object
For Each tr In doc.getElementsByTagName("table")(0).getElementsByTagName("tr")
Set tds = tr.getElementsByTagName("td")
If tds.Length > 0 Then
'日付、タイトル、URL取得
dt = Format(Trim(tds(0).innerText), "mm/dd")
title = Trim(tds(4).innerText)
url = Trim(tds(4).getElementsByTagName("a")(0).getAttribute("href"))

If dt = srchDt Then
'エクセルに書き込み
cnt = cnt + 1
Sheets(writeSheet).Cells(cnt, 1).Value = dt
Sheets(writeSheet).Cells(cnt, 2).Value = title
Sheets(writeSheet).Cells(cnt, 3).Value = url
End If
End If
Next
End Sub

プロシージャの上部に設定項目を書いてます。
webUrlには接続先のURLを入れてください。
writeSheetには書き込み先のシート名を入れてください。
srchDtには抽出対象の日付を入れてください。

お望みのものと違ってたらすいません。
それと、この部分は修正の必要があると思います。

dt = Format(Trim(tds(0).innerText), "mm/dd")
title = Trim(tds(4).innerText)
url = Trim(tds(4).getElementsByTagName("a")(0).getAttribute("href"))

一番左の項目が日付、５番目の項目がタイトル、URLと仮定しています。
もし日付が2番目、タイトル、URLが4番目なら

dt = Format(Trim(tds(1).innerText), "mm/dd")
title = Trim(tds(3).innerText)
url = Trim(tds(3).getElementsByTagName("a")(0).getAttribute("href"))

のようになります。

HTMLの書き方によっては動作しないと思うので、データ部分がどんな構造になってるか教えていただければ
なおせると思います。

下記のHTMLで実験しました。

[サンプルHTML]
<html>
<head>
<title>テスト</title>
</head>
<body>
<table border="1">
<tr>
<th>日付</th>
<th>・・・</th>
<th>・・・</th>
<th>・・・</th>
<th>タイトル</th>
</tr>
<tr>
<td>8/1</td>
<td></td>
<td></td>
<td></td>
<td>
<a href="http://omoshiroi">面白い</a>
</td>
</tr>
<tr>
<td>8/6</td>
<td></td>
<td></td>
<td></td>
<td>
<a href="http://tanoshi">楽しい</a>
</td>
</tr>
<tr>
<td>8/16</td>
<td></td>
<td></td>
<td></td>
<td>
<a href="http://warai">笑い</a>
</td>
</tr>
<tr>
<td>8/21</td>
<td></td>
<td></td>
<td></td>
<td>
<a href="http://omoshiroi">悲しい</a>
</td>
</tr>
<tr>
<td>9/5</td>
<td></td>
<td></td>
<td></td>
<td>
<a href="http://totemotaihen">とても大変</a>
</td>
</tr>
<tr>
<td>10/1</td>
<td></td>
<td></td>
<td></td>
<td>
<a href="http://kinkyu">緊急</a>
</td>
</tr>
<tr>
<td>10/8</td>
<td></td>
<td></td>
<td></td>
<td>
<a href="http://isogashikatta">忙しかった</a>
</td>
</tr>
<tr>
<td>10/14</td>
<td></td>
<td></td>
<td></td>
<td>
<a href="http://erai">偉い</a>
</td>
</tr>
</table>
</body>
</html>

補足

jA6uDWNL様、丁寧な回答ありがとうございます。
申し訳ございません。
サイトのURLは「PHP」でした。

ソースの一部を載せます。

<h2 class="title border-radius">トピックス<span></span></h2>
<div class="block"><table><tr><th>...</th><th>日付</th><th>...</th><th>...</th><th>タイトル</th><th>...</th></tr><tr><td>なし</td><td>10/18</td><td>なし</td><td>なし</td><td><span style='color:#dc143c;font-weight:bold;'></span>　<a href='「タイトル」のリンクアドレス'>面白い</a></td><td width='40'></td></tr>

このような感じでPHPのサイトはできています。
また、書いて頂いたプログラムを実行してみたのですが、
For Each tr In doc.getElementsByTagName("table")(0).getElementsByTagName("tr")
のところでエラーが表示されます。
（ネットで調べてみたらtrオブジェクトをSetしていないからと書いてあったのですが、どうなのでしょうか？）

このプログラムが出来たらとても助かります！
よろしくお願い致します。