VBAでの指定URLからのデータ抽出について

発生している問題
VBAでMSXML2.XMLHTTPを用いて、指定URLからデータを抽出しようとしています。
対象URLのリストを1件ずつループで処理したいのですが、出力する際取得済みのURLのデータを重複して出力してしまいます。

前提
１．対象URLは複数件
２．対象のURLに対してHTTPリクエストを行い、データを抽出
２．抽出したデータを加工してExcelシートに出力
４．リストから次のURLを取得し、2～3の処理を繰り返す

コードは以下の通りです

Sub sub2()
    Dim objHttpReq As Object
    Dim objHtmlDoc As Object
    Dim objHtmlElem As Object
    Dim iStatusCode As Integer
    Dim wsIn As Worksheet, wsOut As Worksheet
    Dim iDstRow As Integer
    Dim rngList As Range, rng As Range
    ～（略）～
    
    Set wsIn = ThisWorkbook.Worksheets("Sheet2")
    Set wsOut = ThisWorkbook.Worksheets("Sheet3")
    With wsIn.Range("F3").CurrentRegion
        Set rngList = .Offset(1).Resize(.Rows.Count - 1)
    End With
    strYear = wsIn.Range("D3").Value
    
    Set objHttpReq = CreateObject("MSXML2.XMLHTTP")
    Set objHtmlDoc = CreateObject("htmlfile")
    objHtmlDoc.DesignMode = "on"
    
    iDstRow = 1
    For Each rng In rngList
        DoEvents
        
        strURL = rng.Value
        objHttpReq.Open "GET", strURL
        objHttpReq.Send
    
        ' ダウンロード待ち
        Do While objHttpReq.readyState <> 4
            DoEvents
        Loop
    
       iStatusCode = objHttpReq.Status
       ' ステータス判定
       If iStatusCode = 200 Then
            objHtmlDoc.write objHttpReq.responseText
            For Each objHtmlElem In objHtmlDoc.getElementsByTagName("p")
                ～（略）～
            Next
        End If
    Next
    
    Set objHtmlDoc = Nothing
    Set objHttpReq = Nothing
    
End Sub

（2021/06/19 20:00　質問内容の記載が途中で切れてしまっていたので、続きを下記に追記します。）
期待結果
各URLから抽出したデータが、Excelシートに下記のように出力されること

1行目　URL1の抽出データ
2行目　URL2の抽出データ
3行目　URL3の抽出データ

実行結果
上記コードを実行したところ、各URLから抽出したデータが下記のように重複してExcelシートに出力されておりました。

1行目　URL1の抽出データ
2行目　URL1の抽出データ　←1行目と重複
3行目　URL2の抽出データ
4行目　URL1の抽出データ　←1行目と重複
5行目　URL2の抽出データ　←3行目と重複
6行目　URL3の抽出データ

試したこと
当該コードを下記のように修正したところ、期待結果通りに抽出データが重複せずに出力されることが確認できました。ですが、実現したいこと（URL複数件からのデータ抽出）に対して、コードが適切か判断がつきません。そのため、修正コードが適切かご教示いただきたく、または参照すべきドキュメント等ご教示いただけますと幸いです。

修正コード１（ループの中で、Set objHtmlDoc = CreateObject("htmlfile")とSet objHtmlDoc = Nothing　を実施するように変更）：

Sub sub2()
    ～（略）～
    Set objHttpReq = CreateObject("MSXML2.XMLHTTP")
    objHtmlDoc.DesignMode = "on"
    
    iDstRow = 1
    For Each rng In rngList
        DoEvents
        
        strURL = rng.Value
        objHttpReq.Open "GET", strURL
        objHttpReq.Send
    
        ' ダウンロード待ち
        Do While objHttpReq.readyState <> 4
            DoEvents
        Loop
    
       iStatusCode = objHttpReq.Status
       ' ステータス判定
       If iStatusCode = 200 Then
       	    Set objHtmlDoc = CreateObject("htmlfile")
                ～（略）～
            Set objHtmlDoc = Nothing
        End If
    Next
    
    Set objHttpReq = Nothing
    
End Sub

修正コード２（データを抽出後、objHtmlDoc.Close　を実行するように変更）：

Sub sub2()
    ～（略）～
    Set objHttpReq = CreateObject("MSXML2.XMLHTTP")
    Set objHtmlDoc = CreateObject("htmlfile")
    objHtmlDoc.DesignMode = "on"
    
    iDstRow = 1
    For Each rng In rngList
        DoEvents
        
        strURL = rng.Value
        objHttpReq.Open "GET", strURL
        objHttpReq.Send
    
        ' ダウンロード待ち
        Do While objHttpReq.readyState <> 4
            DoEvents
        Loop
    
       iStatusCode = objHttpReq.Status
       ' ステータス判定
       If iStatusCode = 200 Then
            objHtmlDoc.write objHttpReq.responseText
                ～（略）～
            objHtmlDoc.Close
        End If
    Next
    
    Set objHtmlDoc = Nothing
    Set objHttpReq = Nothing
    
End Sub

補足情報（FW/ツールのバージョンなど）
OS: Windows10
Microsoft Visual Basic for Applications 7.1

itagagaki

2021/06/19 05:48

デバッグはしてみましたか？

mzn59

2021/06/19 06:04

デバッグを実施し、下記２点・objHttpReq.responseTextには対象URLのHTMLドキュメントのみ格納されていること・コード中のFor Each objHtmlElem In objHtmlDoc.getElementsByTagName("p")~Nextの処理では重複データに対して処理を行っていることは確認しました。そのため、writeメソッドでHTMLドキュメントにHTML文字列を書き込む際に重複して書き込まれたのかと考えていました。

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

回答1件

ベストアンサー

たぶんobjHtmlDoc.write objHttpReq.responseTextではobjHtmlDocにどんどん追加していくのではないでしょうか。上書きではなく。

なので、

VBA
1For Each rng In rngList
2      .
3      .
4      .
5    If iStatusCode = 200 Then
6        Set objHtmlDoc = CreateObject("htmlfile")
7        objHtmlDoc.write objHttpReq.responseText
8          .
9          .
10          .
11        Set objHtmlDoc = Nothing
12    End If
13Next