ホーム>source

最初の列にセット番号を入力し、Excelでそれらをオンラインで検索し、セット名、レンガ数などの詳細を入力して、レゴコレクションのリストを作成したかったのです...

これは私のコードです:

Option Explicit  
Sub BrickLinkDataExtraction()
    Dim x As Integer
    Dim i As Integer
    Dim IE As New InternetExplorer
    For i = 5 To Cells(Rows.Count, 1).End(xlUp).Row
        IE.navigate "https://brickset.com/sets/" & Cells(RowIndex:=i, columnindex:=1).Value
        IE.Visible = False
        Do
            DoEvents
        Loop Until IE.readyState = READYSTATE_COMPLETE 'hier moet ik zeggen "tot rijen vol zijn", zoiets? IsEmpty(Range("i+1" & "A"))
        Dim Doc As HTMLDocument
        Set Doc = IE.document
        Dim NAME As String
        NAME = Trim(Doc.getElementsByTagName("dd")(1).innerText)
        Dim THEME As String
        THEME = Trim(Doc.getElementsByTagName("dd")(4).innerText)
        Dim YEAR As String
        YEAR = Trim(Doc.getElementsByTagName("dd")(6).innerText)
        Dim BRICKS As String
        BRICKS = Trim(Doc.getElementsByTagName("dd")(8).innerText)
        Dim MINIFIGS As String
        MINIFIGS = Trim(Doc.getElementsByTagName("dd")(9).innerText)
        If IsEmpty(Cells(RowIndex:=i, columnindex:=2)) Then
            Cells(RowIndex:=i, columnindex:=2).Value = NAME
        End If
        If IsEmpty(Cells(RowIndex:=i, columnindex:=3)) Then
            Cells(RowIndex:=i, columnindex:=3).Value = BRICKS
        End If
        If IsEmpty(Cells(RowIndex:=i, columnindex:=4)) Then
            Cells(RowIndex:=i, columnindex:=4).Value = MINIFIGS
        End If
        If IsEmpty(Cells(RowIndex:=i, columnindex:=5)) Then
            Cells(RowIndex:=i, columnindex:=5).Value = THEME
        End If
        If IsEmpty(Cells(RowIndex:=i, columnindex:=6)) Then
            Cells(RowIndex:=i, columnindex:=6).Value = YEAR
        End If
    Next
    IE.Quit
    Cells.Columns.AutoFit
End Sub

コードが同じ順序のタグを持たないセットに到達するか、ミニフィグを使用しない限り、これは正常に機能します。次に、スプ​​レッドシートで間違った情報を取得します。

2番目、5番目、...を指定する代わりに、「名前」へのbeloningが必要であることを指定するにはどうすればよいですか?

例えばhttps://brickset.com/sets/10224 意図したとおりに動作します。だがhttps://brickset.com/sets/10262 ミニフィグ列に元の小売価格を入力します。

また、実行に時間がかからないようにコードを最適化する方法はありますか?

あなたの答え
  • 解決した方法 # 1

    XMLHTTP GETリクエストに切り替えて、必要な情報をすばやく取得します。

    HTMLは、あなたが発見したように興味のあるアイテムだけを選択する良い方法には向いていません。各ページに同じ数のアイテムがない場合、位置の一致は無効になります。

    一貫性のあるパターンは、アイテム名( dt  タグ付き)と値( dd  タグ付き)ペアで来ます。たとえば、 "Name"   "Town Hall" に付属 ;あなたは dt を集めることができます  1つの nodeList の要素 、および dd  別の必要なアイテム名が存在するかどうかを最初に確認するループ。アイテム名のリストの長さは、関連付けられた値のリストの長さと一致するため、アイテムをループして値 nodeList にアクセスするだけで済みます。  必要なアイテム名が見つかった場所と同じインデックスを使用します。


    処理する:

    関心のあるセットを配列 sets に保存します 、私は Sheet1 から読んだ  列A。現在のセット番号をベースURL定数に連結して、レゴセットの実際のURLを取得します。 XMLHTTP GETリクエストは、そのURLに対して発行されます。

    ヘルパー関数 GetHTMLDoc が使用されます 、リクエストを処理して HTMLDocument を返す  ページhtmlで。

    追加のヘルパー関数 GetItemsInfo を使用します 、最近返された HTMLDocument に保存されているページHTMLから必要なさまざまなアイテムを取得するには 。辞書 resultsDict を作成します 、そのキーは関心のあるアイテム、すなわち "Name","Theme" です  など。これらのキーには、最初の vbNullstring があります。  値、およびキーがページで見つかった場合、そのキーの辞書の値はページで見つかった値で上書きされます。

    各ページの結果の辞書は、配列 results に格納されます 、後でループして結果をページに書き込みます。


    TODO:

    エラー処理を追加してこれを開発できます。たとえば、ページが見つからないためにGETリクエストが必要なHTMLを返せない場合、または開始行と終了行の間の列Aの空白セルを処理できない場合。

    無料のSOAPベースのAPIがありますが、最初のドキュメントから興味のあるすべてのアイテムを提供できるかどうかはわかりません。

    戻り文字列の潜在的な不要な文字を処理します。 Â   処理されない場合、シートへの書き込み時に表示されるジェームズボンドのタイトル。その場合、 Replace$(info(i).innerText, Chr$(194), vbNullString) を使用しました 。


    CSSセレクター:

    dd という事実を使用します  関心のあるタグの前に dt が付きます  タグ、親 dl 内  関心のあるタグ:

    これは、すべての dt を収集できることを意味します  親 dl を持つタグ  タグ、CSSセレクターを使用してページスタイリングをターゲットにします。次に、返された nodeList をループします 、各ノードの innerText をチェック  辞書キーに対する値。それらが一致する(存在する)場合、必要なアイテムがページに存在することがわかります。一致する dd があることを考えると  各 dt のタグ  タグ、親要素内で、欲しい値が nodeList の同じインデックスにあることを知っています  私はすべての dd をつかんで戻ることができます  親タグ dl を持つタグ 。その後、見つかった値で辞書の値を上書きできます。

    dl dt のCSSセレクターを適用します 、すべての要素を dt で返す  親 dl を持つタグ  鬼ごっこ。このセレクターは .querySelectorAll を介して適用されます   HTMLDocument の方法 。これは nodeList を返します  誰の .Length  0から始まるインデックスによって個々のノードにアクセスするために走査できます。これは "titles" です  nodeList-各アイテム名が含まれます(例: "Name","Theme" ) 等

    CSSクエリの例:

    同様のCSSクエリが値に使用され、 nodeList を返します  私は info と呼んでいます 、 dl dd を使用


    VBA:

    Option Explicit
    Public Sub GetInfo()
        Dim i As Long, html As HTMLDocument, sets(), http As Object, results(), url As String
        Const BASE_URL As String = "https://brickset.com/sets/"
        Application.ScreenUpdating = False
        With ThisWorkbook.Worksheets("Sheet1")
            Dim lastRow As Long: lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
            If lastRow < 5 Then
                Exit Sub
            ElseIf lastRow = 5 Then
                ReDim sets(1, 1): sets(1, 1) = .Range("A5").Value
            Else
                sets = .Range("A5:A" & lastRow).Value
            End If
            ReDim results(0 To UBound(sets, 1) - 1) 
            Set http = CreateObject("MSXML2.XMLHTTP")
            For i = LBound(sets, 1) To UBound(sets, 1)
                url = BASE_URL & sets(i, 1)
                Set html = GetHTMLDoc(http, url)
                Set results(i - 1) = GetItemsInfo(html)
            Next
            Dim headers()
            headers = Array("Set", "Name", "Theme", "Year released", "Pieces", "Minifigs")
            .Cells(4, 1).Resize(1, UBound(headers) + 1) = headers
            For i = LBound(results) To UBound(results)
                .Cells(i + 5, 2).Resize(1, results(i).Count) = results(i).Items
            Next
        End With
        Application.ScreenUpdating = True
    End Sub
    Public Function GetHTMLDoc(ByVal http As Object, ByVal url As String) As HTMLDocument
        Dim html As New HTMLDocument, sResponse As String
        With http
            .Open "GET", url, False
            .send
            sResponse = StrConv(.responseBody, vbUnicode)
        End With       
        html.body.innerHTML = Mid$(sResponse, InStr(1, sResponse, "<!DOCTYPE "))   
        Set GetHTMLDoc = html
    End Function
    Public Function GetItemsInfo(ByVal html As HTMLDocument) As Object
        Dim titles As Object, info As Object, i As Long
        Dim resultsDict As Object
        Set resultsDict = CreateObject("Scripting.Dictionary")
        resultsDict.Add "Name", vbNullString
        resultsDict.Add "Theme", vbNullString
        resultsDict.Add "Year released", vbNullString
        resultsDict.Add "Pieces", vbNullString
        resultsDict.Add "Minifigs", vbNullString
        With html
            Set titles = .querySelectorAll("dl dt")
            Set info = .querySelectorAll("dl dd")
            For i = 0 To titles.Length - 1
                If resultsDict.Exists(titles(i).innerText) Then
                    resultsDict(titles(i).innerText) = Replace$(info(i).innerText, Chr$(194), vbNullString)
                End If
            Next
        End With
        Set GetItemsInfo = resultsDict
    End Function
    
    

    結果:


    参照(VBE> ツール> 参照):

    Microsoft HTMLオブジェクトライブラリ

関連記事

  • 前へ java - JPAクエリ:サブクエリをグループ化条件に結合する
  • 次へ r - グループごとの回帰