アマゾンの順位をグラフにできるように出力したい

Question

前提・実現したいこと

写真のようにアマゾンの順位を１時間ごとに出力したい

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

実行時エラー'13':
型が一致しません

該当のソースコード

Option Explicit

Sub main()
    '＝＝＝＝＝宣言＝＝＝＝＝＝
    Dim objIE As InternetExplorer
    Dim strUrl As String
    Dim intRowCnt As Integer
    Dim objLink As Variant
    Dim bLoopEnd As Boolean
    Dim htmlDoc As HTMLDocument
    Dim Lists As Variant
    Dim rng As Range
    
    
    
        
    Application.OnTime Now() + TimeValue("00:01:00"), "main"
    
    Range("B1") = "スポーツ"
    
    Range("C1") = "自然哲学"
    
    Range("D1") = "健康法"
    
    strUrl = "https://www.amazon.co.jp/dp/4910001050"
    
    Call getpage(objIE, strUrl)
    
    Set htmlDoc = objIE.document
   
    intRowCnt = 2
    
    Call WaitResponse(objIE)
    Call set_webdata(objIE, intRowCnt)
    

     
End Sub

Sub set_webdata(objIE As Object, rowcnt As Integer)

    Dim intRowStart As Integer
    Dim intRowCnt As Integer
    Dim str As Variant
    Dim htmlDoc As HTMLDocument
    Dim elements As IHTMLElementCollection
    
    Set htmlDoc = objIE.document
    

    intRowStart = rowcnt
    intRowCnt = rowcnt

    For Each str In htmlDoc.getElementsByClassName("zg_hrsr_rank")(1).innerHTML
    Debug.Print elements(1).Content
     Cells(intRowCnt, 2).Value = str.innerHTML
     intRowCnt = intRowCnt + 1
    Next
    intRowCnt = intRowStart
    
    For Each str In htmlDoc.getElementsByClassName("zg_hrsr_rank")(2).innerHTML
     Debug.Print elements(2).Content
     Cells(intRowCnt, 3).Value = str.innerHTML
     intRowCnt = intRowCnt + 1
    Next
    intRowCnt = intRowStart
    
    For Each str In htmlDoc.getElementsByClassName("zg_hrsr_rank")(3).innerHTML
     Debug.Print elements(3).Content
     Cells(intRowCnt, 4).Value = str.innerHTML
     intRowCnt = intRowCnt + 1
    Next
    

End Sub

Sub getpage(ByRef objIE As Object, strUrl As String)

    Set objIE = CreateObject("Internetexplorer.Application")
    
    objIE.Visible = True
    
    objIE.navigate (strUrl)
    
    Call WaitResponse(objIE)
    
End Sub
Sub WaitResponse(objIE As Object)

    Do While objIE.Busy = True Or objIE.readyState < READYSTATE_COMPLETE
        DoEvents
    Loop
End Sub

試したこと

改行するプログラムを消してみたりなどしました

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

ofice excel 365 標準モジュール

Comments

[ttyp03]

どの行でエラーが出るのかくらい書いてください。

[admn]

すいません。二個目のsubのこの行です
For Each str In htmlDoc.getElementsByClassName("zg_hrsr_rank")(1).innerHTML

Answer 1

たぶんあちこちのコードを意味も分からずに切り貼りしたものだと思われます。
コードの意味を理解して使用するようにしましょう。

For Each str In htmlDoc.getElementsByClassName("zg_hrsr_rank")(1).innerHTML

ここでなぜエラーになるかというと、
For Each はは配列やコレクションなど複数の要素を持つオブジェクトの一つ一つの要素にアクセスするものです。
innerHTML で取得できるものは単なる文字列で複数の要素も持たないものですので、「型が一致しません」のエラーになります。

htmlDoc.getElementsByClassName("zg_hrsr_rank")(1).innerHTML ですでに目的のデータ（順位）が取得できているので For Each する必要はないです。
ただし、getElementsByClassName("zg_hrsr_rank") で取得できるコレクションのインデックスは0から始まりますので、最初の順位(スポーツ)は
htmlDoc.getElementsByClassName("zg_hrsr_rank")(0).innerHTML
になります。

とりあえず、下記の部分は、

    For Each str In htmlDoc.getElementsByClassName("zg_hrsr_rank")(1).innerHTML
    Debug.Print elements(1).Content
     Cells(intRowCnt, 2).Value = htmlDoc.getElementsByClassName("zg_hrsr_rank")(1).innerHTML 'str.innerHTML
     intRowCnt = intRowCnt + 1
    Next
    intRowCnt = intRowStart

下記の1行ですみます。それ以外は無意味か、エラーになるコードです。

     Cells(intRowCnt, 2).Value = htmlDoc.getElementsByClassName("zg_hrsr_rank")(0).innerHTML 'str.innerHTML

他にも修正が必要な部分はありますが、あとは自分でコードの意味を理解しながら修正してください。

そのうえで行き詰ったらまた、新規に質問しなおしてください。

Comments

[admn]

何もわからずに張り付けた結果何もわからないまま進めていましたがわかりやすい解説で少し理解することができました。ありがとうございます

Answer 2

たぶんDebug.Printの行ではないかと思います。
elements変数を初期化せずに参照しているのでエラーになっているのでは。
elements変数の必要有無はわかりませんが、とりあえず動作させるなら、該当行をコメントアウトすればよいかと。

追記

1時間に1回1行追加するという観点でコードを見直してみました。
要約するとおそらく以下で済むはずです（動作確認済み）

Sub set_webdata(objIE As InternetExplorer, rowcnt As Integer)

    With objIE.document
        Cells(rowcnt, 2).Value = .getElementsByClassName("zg_hrsr_rank")(0).innerHTML
        Cells(rowcnt, 3).Value = .getElementsByClassName("zg_hrsr_rank")(1).innerHTML
        Cells(rowcnt, 4).Value = .getElementsByClassName("zg_hrsr_rank")(2).innerHTML
    End With

End Sub

あとここでは修正していませんが、main関数から渡すrowcntの値が常に2になっていますが、最終行+1を渡すようにすればよいかと。
もう一点、OnTimeの設定が1分後になっているようなので、1時間後に修正してください（テスト用の設定でしたらスルーしてください）

Comments

[admn]

Dim elements As IHTMLElementCollectionの行とdebug.printの行をコメントアウトしてみましたがまた同じ場所でエラーが出てしまいます。ほかに原因となるところはないでしょうか。

[ttyp03]

回答に追記しました。
ご確認を。

[admn]

最終行＋１というのはどうすればいいのでしょうか。何度もすみません

[ttyp03]

mainでintRowCnt=2のところを以下に変更でよいと思います。

intRowCnt = Range("B1").End(xlDown).Row + 1

[admn]

本質問に関係のないところまで指摘して初心者に優しく教えていただきありがとうございます。しっかりと動作が確認できました。それともう一つたびたび申し訳ないのですが写真のように左側に時間を表示させるにはどうすればいいでしょうか。

[ttyp03]

Withのブロック内先頭に以下を追加で。
Cells(rowcnt, 1).Value = Now

[admn]

すいませんその行を追加したところ
intRowCnt = Range("B1").End(xlDown).Row + 1
の行にオーバーフローしましたというエラーが出ます。
どうすればいいでしょうか