VBAでエクセルにアットコスメのランキングデータを出力する

　アットコスメのランキングデータが欲しいなと思ったのですが、コピペするのは面倒なので、VBAでスクレイピングを行うコードを書いてみました。
　乳液・美容液のランキング1~20位の商品の商品名、会社名、値段、口コミ数を取得します。

Sub ボタン1_Click()

Dim url As String
Dim http As Object
Dim atcosme As Worksheet
Dim check_row As Integer
Dim product_column As Integer
Dim price_column As Integer
Dim brand_column As Integer
Dim votes_column As Integer
Dim rank_column As Integer
Dim rank As Integer
Dim product As String
Dim brand As String
Dim price As String
Dim votes As String
Dim element As HTMLDDElement
Dim HtmlDoc As HTMLDocument
Dim HtmlBuf As Object
Dim t As Single
    
    Set atcosme = ActiveSheet       '   現在のシートを退避
    check_row = 7                   '   7行目から取得開始
    rank_column = 2                  '  順位の列
    product_column = 3               '　製品名の列
    brand_column = 4                 '  ブランド名の列
    price_column = 5                 '  価格の列
    votes_column = 6                 '  口コミ数の列
    rank = 0

    url = "https://www.cosme.net/item/item_id/903/ranking/"
    Set http = CreateObject("MSXML2.XMLHTTP")
    http.Open "GET", url
    http.Send
            Do While http.readyState < 4
                DoEvents
            Loop
        Set HtmlBuf = New HTMLDocument
        HtmlBuf.write http.responseText
        Set HtmlDoc = HtmlBuf
    Do While atcosme.Cells(check_row, rank_column) <> "11"
        Set element = HtmlDoc.getElementsByClassName("summary")(rank)
        If Not element Is Nothing Then
        product = element.getElementsByClassName("item")(0).innerText '製品名
        brand = element.getElementsByClassName("brand")(0).innerText '会社名
        price = element.getElementsByClassName("price")(0).innerText '価格
        votes = element.getElementsByClassName("votes")(0).innerText '口コミ数
        
        atcosme.Cells(check_row, product_column) = product
        atcosme.Cells(check_row, brand_column) = brand
        atcosme.Cells(check_row, price_column) = price
        atcosme.Cells(check_row, votes_column) = votes
    
Exist_out:
    check_row = check_row + 1
    rank = rank + 1
    product = ""
    brand = ""
    price = ""
    votes = ""
    
    Else
        MsgBox "1～10位のランキングを更新します"
    End If

    Loop

'ここから11位~20位
    Set atcosme = ActiveSheet       '   現在のシートを退避
    check_row = 17                   '   7行目から取得開始
    rank_column = 2                  '  順位の列
    product_column = 3               '　製品名の列
    brand_column = 4                 '  ブランド名の列
    price_column = 5                 '  価格の列
    votes_column = 6                 '  口コミ数の列
    rank = 0

    url = "https://www.cosme.net/item/item_id/903/ranking/page/1"
    Set http = CreateObject("MSXML2.XMLHTTP")
    http.Open "GET", url
    http.Send
            Do While http.readyState < 4
                DoEvents
            Loop
        Set HtmlBuf = New HTMLDocument
        HtmlBuf.write http.responseText
        Set HtmlDoc = HtmlBuf
    Do While atcosme.Cells(check_row, rank_column) <> ""
        Set element = HtmlDoc.getElementsByClassName("summary")(rank)
        If Not element Is Nothing Then
        product = element.getElementsByClassName("item")(0).innerText '製品名
        brand = element.getElementsByClassName("brand")(0).innerText '会社名
        price = element.getElementsByClassName("price")(0).innerText '価格
        votes = element.getElementsByClassName("votes")(0).innerText '口コミ数
        
        atcosme.Cells(check_row, product_column) = product
        atcosme.Cells(check_row, brand_column) = brand
        atcosme.Cells(check_row, price_column) = price
        atcosme.Cells(check_row, votes_column) = votes
    
Exist_out1:
    check_row = check_row + 1
    rank = rank + 1
    product = ""
    brand = ""
    price = ""
    votes = ""
    
    Else
        MsgBox "11～20位のランキングを更新します"
    End If
    
    Loop


End Sub

　下記のような形でデータが取得できました！