VBAを用いたスクレイピングで，サイト上のURLがうまく取得できません

前提・実現したいこと

以下のサイトから，病院名とWebサイトのURLを抽出するマクロを作成しています。
使用言語はVBAです。
サイトへのリンク

URLの抽出がうまくいかず，いろいろと調べましたが，わかりませんでした。（惜しいところまでは言っている気がするのですが…）
どなたかアドバイスいただけないでしょうか。よろしくお願いいたします。

抽出対象は，以下のようなコードがたくさん並んでいます。（病院2件分を貼り付けました）
抽出したいURLは，class="m-card-tag-button"のhref部分です。

HTML
1<li class="o-result-article-list__item" data-v-2c442e3e="" data-v-152a6b2e=""><div data-v-4839c9c6="" data-v-152a6b2e="" data-v-2c442e3e=""><!----> <div class="m-article-card is-ad" data-v-4839c9c6=""><button class="m-article-card__toggle-favorite" style="button" data-v-4839c9c6=""><svg aria-hidden="true" focusable="false" data-prefix="fas" data-icon="heart" role="img" xmlns="http://www.w3.org/2000/svg" viewBox="0 0 512 512" class="m-article-card__toggle-favorite__icon svg-inline--fa fa-heart fa-w-16" data-v-4839c9c6=""><path fill="currentColor" d="M462.3 62.6C407.5 15.9 326 24.3 275.7 76.2L256 96.5l-19.7-20.3C186.1 24.3 104.5 15.9 49.7 62.6c-62.8 53.6-66.1 149.8-9.9 207.9l193.5 199.8c12.5 12.9 32.8 12.9 45.3 0l193.5-199.8c56.3-58.1 53-154.3-9.8-207.9z" data-v-4839c9c6="" class=""></path></svg></button> <article class="m-article-card__body" data-v-4839c9c6=""><header class="m-article-card__header" data-v-4839c9c6=""><h1 class="m-article-card__header__title" data-v-4839c9c6=""><a href="https://itp.ne.jp/info/082302344127040960/" target="_blank" class="m-article-card__header__title__link" data-v-4839c9c6="">
2            ひまわり動物病院
3          </a></h1> <!----> <p class="m-article-card__header__category" data-v-4839c9c6="">
4            獣医師、動物病院、ペットトリミング、ペット美容室、ペットホテル
5          </p></header> <div class="m-article-card__lead" data-v-4839c9c6=""><a href="https://itp.ne.jp/info/082302344127040960/" target="_blank" class="m-article-card__lead__thumbnail u-hover" data-v-4839c9c6=""><img src="https://resources.itp.ne.jp/082302344127040960/thumb" alt="thumbnail" class="u-wh100p" data-v-4839c9c6=""></a> <div class="m-article-card__lead__body" data-v-4839c9c6=""><p class="m-article-card__lead__catch" data-v-4839c9c6="">平日夜７時　日・祝昼１２時迄
6往診 トリミング ホテル 送迎</p> <p class="m-article-card__lead__caption" data-v-4839c9c6="">
7            【最寄駅】東海駅
8          </p> <p class="m-article-card__lead__caption" data-v-4839c9c6="">
9            【電話番号】          029-270-5900
10          </p> <p class="m-article-card__lead__caption" data-v-4839c9c6="">
11            【住所】茨城県那珂郡東海村大字白方１７４９－４１
12          </p> <div class="m-article-card__tag" data-v-4839c9c6=""><!----> <!----> <a href="http://www.ah-himawari.com" target="_blank" class="m-card-tag-button" data-v-33370a0e="" data-v-4839c9c6=""><svg aria-hidden="true" focusable="false" data-prefix="fas" data-icon="globe" role="img" xmlns="http://www.w3.org/2000/svg" viewBox="0 0 496 512" class="svg-inline--fa fa-globe fa-w-16" data-v-33370a0e="" data-v-4839c9c6=""><path fill="currentColor" d="M336.5 160C322 70.7 287.8 8 248 8s-74 62.7-88.5 152h177zM152 256c0 22.2 1.2 43.5 3.3 64h185.3c2.1-20.5 3.3-41.8 3.3-64s-1.2-43.5-3.3-64H155.3c-2.1 20.5-3.3 41.8-3.3 64zm324.7-96c-28.6-67.9-86.5-120.4-158-141.6 24.4 33.8 41.2 84.7 50 141.6h108zM177.2 18.4C105.8 39.6 47.8 92.1 19.3 160h108c8.7-56.9 25.5-107.8 49.9-141.6zM487.4 192H372.7c2.1 21 3.3 42.5 3.3 64s-1.2 43-3.3 64h114.6c5.5-20.5 8.6-41.8 8.6-64s-3.1-43.5-8.5-64zM120 256c0-21.5 1.2-43 3.3-64H8.6C3.2 212.5 0 233.8 0 256s3.2 43.5 8.6 64h114.6c-2-21-3.2-42.5-3.2-64zm39.5 96c14.5 89.3 48.7 152 88.5 152s74-62.7 88.5-152h-177zm159.3 141.6c71.4-21.2 129.4-73.7 158-141.6h-108c-8.8 56.9-25.6 107.8-50 141.6zM19.3 352c28.6 67.9 86.5 120.4 158 141.6-24.4-33.8-41.2-84.7-50-141.6h-108z" data-v-33370a0e="" data-v-4839c9c6="" class=""></path></svg>
13              ウェブサイト
14              <svg aria-hidden="true" focusable="false" data-prefix="fas" data-icon="chevron-right" role="img" xmlns="http://www.w3.org/2000/svg" viewBox="0 0 320 512" class="svg-inline--fa fa-chevron-right fa-w-10" data-v-33370a0e="" data-v-4839c9c6=""><path fill="currentColor" d="M285.476 272.971L91.132 467.314c-9.373 9.373-24.569 9.373-33.941 0l-22.667-22.667c-9.357-9.357-9.375-24.522-.04-33.901L188.505 256 34.484 101.255c-9.335-9.379-9.317-24.544.04-33.901l22.667-22.667c9.373-9.373 24.569-9.373 33.941 0L285.475 239.03c9.373 9.372 9.373 24.568.001 33.941z" data-v-33370a0e="" data-v-4839c9c6="" class=""></path></svg></a></div></div></div></article></div></div></li>
15<li class="o-result-article-list__item" data-v-2c442e3e="" data-v-152a6b2e=""><div data-v-4839c9c6="" data-v-152a6b2e="" data-v-2c442e3e=""><!----> <div class="m-article-card" data-v-4839c9c6=""><button class="m-article-card__toggle-favorite" style="button" data-v-4839c9c6=""><svg aria-hidden="true" focusable="false" data-prefix="fas" data-icon="heart" role="img" xmlns="http://www.w3.org/2000/svg" viewBox="0 0 512 512" class="m-article-card__toggle-favorite__icon svg-inline--fa fa-heart fa-w-16" data-v-4839c9c6=""><path fill="currentColor" d="M462.3 62.6C407.5 15.9 326 24.3 275.7 76.2L256 96.5l-19.7-20.3C186.1 24.3 104.5 15.9 49.7 62.6c-62.8 53.6-66.1 149.8-9.9 207.9l193.5 199.8c12.5 12.9 32.8 12.9 45.3 0l193.5-199.8c56.3-58.1 53-154.3-9.8-207.9z" data-v-4839c9c6="" class=""></path></svg></button> <article class="m-article-card__body" data-v-4839c9c6=""><header class="m-article-card__header" data-v-4839c9c6=""><h1 class="m-article-card__header__title" data-v-4839c9c6=""><a href="https://itp.ne.jp/info/097120699000000899/" target="_blank" class="m-article-card__header__title__link" data-v-4839c9c6="">
16            山内動物病院
17          </a></h1> <!----> <!----></header> <div class="m-article-card__lead" data-v-4839c9c6=""><a href="https://itp.ne.jp/info/097120699000000899/" target="_blank" class="m-article-card__lead__thumbnail u-hover" data-v-4839c9c6=""><img src="https://resources.itp.ne.jp/097120699000000899/thumb" alt="thumbnail" class="u-wh100p" data-v-4839c9c6=""></a> <div class="m-article-card__lead__body" data-v-4839c9c6=""><p class="m-article-card__lead__catch" data-v-4839c9c6="">土曜日・日曜日・祝日も診療している宇都宮市の動物病院</p> <p class="m-article-card__lead__caption" data-v-4839c9c6="">
18            【最寄駅】宇都宮駅 / 東武宇都宮駅
19          </p> <p class="m-article-card__lead__caption" data-v-4839c9c6="">
20            【電話番号】          028-622-3618
21          </p> <p class="m-article-card__lead__caption" data-v-4839c9c6="">
22            【住所】栃木県宇都宮市栄町４－１８
23          </p> <div class="m-article-card__tag" data-v-4839c9c6=""><!----> <!----> <!----></div></div></div></article></div></div></li>

発生している問題・エラーメッセージ

病院名はうまく抽出できたのですが，URLがすべて同じ文字列になってしまいます。
以下は実行結果の一部です。
おがわ動物病院 https://ogawaah.net/
ハートフルおおもりのどうぶつ病院 https://ogawaah.net/
どうぶつのセンター病院 https://ogawaah.net/
小鳥のセンター病院・本院 https://ogawaah.net/
小鳥のセンター病院・池袋院 https://ogawaah.net/
菅原動物病院 https://ogawaah.net/

エラーメッセージは出ていません。処理自体は正常に終わっているようです。

該当のソースコード

VBA
1Sub test5()
2
3'    検索ワード
4    Dim Key As String, KeyURL As String
5    Key = "動物病院"
6    KeyURL = Application.WorksheetFunction.EncodeURL(Key)
7        
8'    IE起動
9    Dim IE As InternetExplorer
10    Set IE = CreateObject("InternetExplorer.Application")
11    IE.Visible = True
12    IE.navigate "https://itp.ne.jp/keyword/?keyword=" & KeyURL
13    
14    Call WaitResponse(IE)
15    
16'    情報取得
17    Dim SearchClassName As Object, ListItem As Object
18    Const OutputCol As Long = 1
19    Dim OutputRow As Long
20    Dim Name As String, URL As String
21    OutputRow = 2
22    Set SearchClassName = IE.document.getElementsByClassName("o-result-article-list__item")
23    
24    For Each ListItem In SearchClassName
25    
26'        Name
27        If Not ListItem.getElementsByClassName("m-article-card__header__title")(0) Is Nothing Then
28            Name = Trim(ListItem.getElementsByClassName("m-article-card__header__title")(0).innerText)
29        End If
30        
31'        URL
32        Dim Anchor As Object
33        For Each Anchor In ListItem.document.Links
34            If InStr(Anchor.innerText, "ウェブサイト") > 0 Then
35                URL = Anchor.href
36                Exit For
37            End If
38        Next Anchor
39
40        Cells(OutputRow, OutputCol) = Name
41        Cells(OutputRow, OutputCol + 1) = URL
42        
43        OutputRow = OutputRow + 1
44
45    Next ListItem
46    
47    IE.Quit
48    
49    MsgBox "処理が完了しました。" & vbCrLf & "処理件数：" & OutputRow - 2 & "件"
50
51End Sub

試したこと

この部分を，

VBA
1'    URL
2   Dim Anchor As Object
3   For Each Anchor In ListItem.document.Links
4       If InStr(Anchor.innerText, "ウェブサイト") > 0 Then
5           URL = Anchor.href
6           Exit For
7       End If
8   Next Anchor

Fro Each ListItem In SearchClassNameの外に出して，
このように書き換えてみました。

VBA
1'    URL
2    Dim Anchor As Object
3    Dim j As Long
4    For Each Anchor In IE.document.Links
5        If InStr(Anchor.innerText, "ウェブサイト") > 0 Then
6            Cells(2 + j, OutputCol + 1) = Anchor.href
7            j = j + 1
8        End If
9    Next Anchor

すると，正常に動作するようにはなりましたが，
対象のWebサイトでは，病院ごとにURLの記載があったりなかったりします。
なので，病院名のセルとURLのセルの位置関係が合わなくなってしまいました。
できれば，Fro Each ListItem In SearchClassNameのなかで，ListItemごとに処理したいです。

補足情報（FW/ツールのバージョンなど）

Excel2013
Internet Explorer11

行動規範の内容に同意します

回答3件

ベストアンサー

meg_ さんの回答の内容に近いですが、AnchorのFor Eachの際にListItem.document.Linksと、親Document=ページ全体まで戻ってリンクを取得しているのが原因です。

ListItem.getElementsByTagName("a")や、
meg_さんの回答のように~.getElementsByClassName("m-card-tag-button")でListItem単位で取得する必要があります。

また、「Microsoft HTML Object Library」を参照設定すれば、HTMLの要素の型を明示できるため、そちらも設定した方がやりやすいと思います(以下のコードでMSHTML.~となっているのが、その参照設定によって使えるようになった型です)。

vba
1Sub teratail258424()
2    
3    'TODO:対象のシートを明示する。
4    Dim outputSheet As Excel.Worksheet
5    Set outputSheet = ThisWorkbook.ActiveSheet
6    
7'    検索ワード
8    Dim Key As String, KeyURL As String
9    Key = "動物病院"
10    KeyURL = Application.WorksheetFunction.EncodeURL(Key)
11
12'    IE起動
13    Dim IE As InternetExplorer
14    Set IE = CreateObject("InternetExplorer.Application")
15    IE.Visible = True
16    IE.navigate "https://itp.ne.jp/keyword/?keyword=" & KeyURL
17
18    Call WaitResponse(IE)
19
20'    情報取得
21    Dim SearchClassName As MSHTML.IHTMLElementCollection
22    Dim ListItem As MSHTML.HTMLUnknownElement
23    Const OutputCol As Long = 1
24    Dim OutputRow As Long
25    Dim Name As String, URL As String
26    OutputRow = 2
27    
28    Dim htmlDoc As MSHTML.HTMLDocument
29    Set htmlDoc = IE.document
30    
31    Set SearchClassName = htmlDoc.getElementsByClassName("o-result-article-list__item")
32    
33    For Each ListItem In SearchClassName
34
35'        Name
36        Name = ""
37        Dim headerItems As MSHTML.IHTMLElementCollection
38        Set headerItems = ListItem.getElementsByClassName("m-article-card__header__title")
39        If headerItems.Length > 0 Then
40            Name = Trim(headerItems.Item(0).innerText)
41        End If
42        
43
44'        URL
45        URL = "" '「ウェブサイト」ボタンがない場合は空欄とするため。
46        Dim Anchor As MSHTML.HTMLAnchorElement
47        For Each Anchor In ListItem.getElementsByTagName("a")
48            If InStr(Anchor.innerText, "ウェブサイト") > 0 Then
49                URL = Anchor.href
50                Exit For
51            End If
52        Next Anchor
53
54        With outputSheet.Cells
55            .Item(OutputRow, OutputCol).Value = Name
56            .Item(OutputRow, OutputCol + 1).Value = URL
57        End With
58        
59        OutputRow = OutputRow + 1
60
61    Next ListItem
62    
63    IE.Quit
64
65    MsgBox "処理が完了しました。" & vbCrLf & "処理件数：" & OutputRow - 2 & "件"
66
67End Sub

投稿2020/05/03 09:07

imihito

総合スコア2166

takasaki_

2020/05/03 09:17

ご丁寧に教えていただいて，ありがとうございました！これを参考に，他の情報も取得してみたいと思います。

行動規範の内容に同意します

VBA
1Dim SearchClassName As Object
2    Dim animal As Object
3    Dim url As Object
4    Dim i As Object
5    
6    Set SearchClassName = IE.document.getElementsByClassName("m-article-card__body")
7
8    For Each i In SearchClassName
9        Set animal = i.getElementsByClassName("m-article-card__header__title__link")
10        Debug.Print animal(0).Text
11        Set url = i.getElementsByClassName("m-card-tag-button")
12        If url.Length > 0 Then
13            Debug.Print url(0).href
14        End If
15    Next i

投稿2020/05/03 08:36

meg_

総合スコア10762

"ウェブサイト"をNameに変更してみました。

VBA
1'URL
2Dim Anchor As Object
3For Each Anchor In ListItem.document.Links
4    'If InStr(Anchor.innerText, "ウェブサイト") > 0 Then
5    If InStr(Anchor.innerText, Name) > 0 Then
6        URL = Anchor.href
7        Exit For
8    End If
9Next Anchor