我需要通過Excel 2010 VBA下載eBay運輸費用？

Question

我一直在嘗試幾天從ebay下載非免費送貨費用。我有頁面的項目編號。鏈接應該在ebay上進入正確的頁面。在嘗試轉到頁面並下載數據時，Excel掛起並且從不恢復。我真的需要這些運費，基本上是時間。如果這段代碼不能修復而不能掛起，有人可以告訴我如何獲取我需要的信息到Excel中嗎？我有其他的代碼可以從ebay上得到許多頁面上的易趣項目編號，這與其實非常相似，並且效果很好。

itemNumberAlone = Range("a" & eachItem).Value 
With ActiveSheet.QueryTables.Add(Connection:= _ 
"URL;http://www.ebay.com/itm/" & itemNumberAlone & "?ru=http%3A%2F%2Fwww.ebay.com%2Fsch%2Fi.html%3F_from%3DR40%26_sacat%3D0%26_nkw%3D" & itemNumberAlone & "%26_rdc%3D1" _ 
, Destination:=Range("$bZ$1")) 
.Name = "second ebay links" 
.FieldNames = True 
.RowNumbers = False 
.FillAdjacentFormulas = False 
.PreserveFormatting = True 
.RefreshOnFileOpen = True 
.BackgroundQuery = True 
.RefreshStyle = xlOverwriteCells 
.SavePassword = False 
.SaveData = True 
.AdjustColumnWidth = True 
.RefreshPeriod = 0 
.WebSelectionType = xlEntirePage 
.WebFormatting = xlWebFormattingNone 
.WebPreFormattedTextToColumns = True 
.WebConsecutiveDelimitersAsOne = True 
.WebSingleBlockTextImport = False 
.WebDisableDateRecognition = False 
.WebDisableRedirections = False 
.Refresh BackgroundQuery:=False 
End With 
Do While Not IsError(Application.Match("Shipping and handling", Range("bz1:bz1000"), 0)) 
If IsError(Application.Match("Shipping and handling", Range("bz1:bz1000"), 0)) Then Exit Do 
If Not IsError(Application.Match("Shipping and handling", Range("bz1:bz1000"), 0)) Then 
shippingRow = Application.Match("Shipping and handling", Range("bz1:bz1000"), 0) + 1 
shippingCell = Range("bz" & shippingRow).Value 
If Left(shippingCell, 2) <> "US" Then 
Range("bz" & shippingRow - 1).ClearContents 
Else 
Range("c" & eachItem).Value = Right(shippingCell, Len(shippingCell) - 2) 
End If 
End If 
Loop 
End If 
Next 

Answer 1

我認爲你將不得不學習DOM自動操作來乾淨地做到這一點。我查看了ebay頁面上的HTML，對於之前沒有使用過DOM自動化的人來說，這可能有點兒意義。我並沒有打算寫這篇文章，但聽起來你有點兒尷尬，所以你要走了。你可以用它來學習。請記住，這將在短期內發揮作用，但當他們更改HTML時，將會失敗。

Option Explicit 

Sub Get_Ebay_Shipping_Charges() 
Dim IE As Object, DOM_DOC As Object 
Dim URL$, SHIPPING_CHARGES$ 
Dim SHIPPING_AMOUNT 
Dim i&, x& 
Dim EL, EL_COLLECTION, CHILD_NODES, TABLE_NODES, TABLE_ROW_NODES, TABLE_DATA_NODES, ITEM_NUMBER_ARRAY 
Dim WS As Excel.Worksheet 
Dim ITEM_NOT_FOUND As Boolean 

''You should change this to the worksheet name you want to use 
''ie Set WS = ThisWorkbook.Sheets("Ebay") 
Set WS = ThisWorkbook.Sheets(1) 

''Create an Internet Explorer Object 
Set IE = CreateObject("InternetExplorer.Application") 

''Make it visible 
IE.Visible = True 

''You can replace this with an array that is built from your spreadsheet, this is just for demo purposes 
ITEM_NUMBER_ARRAY = Array("290941626676", "130942854921", "400035340501") 

''In your code, you can start your loop here to handle the list of items 
''This code is a little different for demo purposes 
For x = 0 To UBound(ITEM_NUMBER_ARRAY) 

    ''Here is your URL 
    URL = "http://www.ebay.com/itm/" & ITEM_NUMBER_ARRAY(x) & "?ru=http%3A%2F%2Fwww.ebay.com%2Fsch%2Fi.html%3F_from%3DR40%26_sacat%3D0%26_nkw%3D" & ITEM_NUMBER_ARRAY(x) & "%26_rdc%3D1" 

    ''Navigate to your URL 
    IE.navigate URL 

    ''This loop will wait until the page is received from the server - the page was hanging for me too so I added a counter to exit after a certain number of loops (this is the i variable) 
    Do Until IE.readystate = 4 Or i = 50000 
     i = i + 1 
     DoEvents 
    Loop 
    i = 0 

    ''This sets the DOM document 
    Set DOM_DOC = IE.document 

    ''First get a collection of table names 
    Set EL_COLLECTION = DOM_DOC.GetElementsByTagName("table") 
    If IsEmpty(EL_COLLECTION) Then ITEM_NOT_FOUND = True: GoTo ERR_EXIT 

    ''Then look for the table classname that matches the one we want (in this case "sh-tbl") and set the childnodes to a new collection 
    For Each EL In EL_COLLECTION 
     If EL.ClassName = "sh-tbl" Then 
      Set CHILD_NODES = EL.ChildNodes 
      Exit For 
     End If 
    Next EL 
    If IsEmpty(CHILD_NODES) Then ITEM_NOT_FOUND = True: GoTo ERR_EXIT 

    ''Next look for the TBODY element in the childnodes collection and set the childnodes of the TBODY element when found 
    For Each EL In CHILD_NODES 

     If Not TypeName(EL) = "DispHTMLDOMTextNode" Then 

      If EL.tagname = "TBODY" Then 
       Set TABLE_NODES = EL.ChildNodes 
       Exit For 
      End If 

     End If 

    Next EL 
    If IsEmpty(TABLE_NODES) Then ITEM_NOT_FOUND = True: GoTo ERR_EXIT 

    ''Find the TR element and set its childnodes to another collection 
    For Each EL In TABLE_NODES 

     If Not TypeName(EL) = "DispHTMLDOMTextNode" Then 

      If EL.tagname = "TR" Then 
       Set TABLE_ROW_NODES = EL.ChildNodes 
       Exit For 
      End If 

     End If 

    Next EL 
    If IsEmpty(TABLE_ROW_NODES) Then ITEM_NOT_FOUND = True: GoTo ERR_EXIT 

    ''Find the first TD element and get it's childnodes 
    For Each EL In TABLE_ROW_NODES 

     If Not TypeName(EL) = "DispHTMLDOMTextNode" Then 

      If EL.tagname = "TD" Then 
       Set TABLE_DATA_NODES = EL.ChildNodes 
       Exit For 
      End If 

     End If 

    Next EL 
    If IsEmpty(TABLE_DATA_NODES) Then ITEM_NOT_FOUND = True: GoTo ERR_EXIT 

    ''The first DIV element holds the shipping information so when it is found, get the innertext of that element 
    For Each EL In TABLE_DATA_NODES 

     If Not TypeName(EL) = "DispHTMLDOMTextNode" Then 

      If EL.tagname = "DIV" Then 
       SHIPPING_CHARGES = EL.INNERTEXT 
       Exit For 
      End If 

     End If 

    Next EL 

    ''Make sure a shipping charge was found 
    If SHIPPING_CHARGES = vbNullString Then MsgBox "No shipping charges found for item " & ITEM_NUMBER_ARRAY(x): GoTo ERR_EXIT 

    If IsNumeric(Right(SHIPPING_CHARGES, InStr(SHIPPING_CHARGES, Chr(36)))) Then 
     SHIPPING_AMOUNT = Right(SHIPPING_CHARGES, InStr(SHIPPING_CHARGES, Chr(36))) 
    Else 
     SHIPPING_AMOUNT = SHIPPING_CHARGES 
    End If 

    ''You may have to change this to fit your spreadsheet 
    WS.Cells(x + 1, 3).Value = SHIPPING_AMOUNT 

ERR_EXIT: 
     If ITEM_NOT_FOUND = True Then MsgBox "No Page Was Found For Item " & ITEM_NUMBER_ARRAY(x): ITEM_NOT_FOUND = False 

Next x 

IE.Quit 
Set IE = Nothing 

End Sub 

如果你堅持使用現有的代碼，你也可以嘗試查詢後刪除querytables。

Dim QRY_TABLE As QueryTable 

For Each QRY_TABLE In ThisWorkbook.Sheets(1).QueryTables 
    QRY_TABLE.Delete 
Next 

此方法不會刪除電子表格上的querytable值，但會終止querytable連接。如果你有太多的這些，它可能會導致崩潰。

最後一個建議，如果你的工作簿包含很多vlookups那麼這可能是真正的罪魁禍首。祝你好運！

Answer 2

您可以使用xmlHTTP對象，它可以更輕鬆地下載數據，並且不會讓excel卡住。

Sub xmlHttp() 
    Dim xmlHttp As Object 
    Set xmlHttp = CreateObject("MSXML2.ServerXMLHTTP.6.0") 

    Dim ITEM_NUMBER_ARRAY As Variant 
    ITEM_NUMBER_ARRAY = Array("290941626676", "130942854921", "400035340501") 
    For x = 0 To UBound(ITEM_NUMBER_ARRAY) 

     ''Here is your URL 
     URL = "http://www.ebay.com/itm/" & ITEM_NUMBER_ARRAY(x) & "?ru=http%3A%2F%2Fwww.ebay.com%2Fsch%2Fi.html%3F_from%3DR40%26_sacat%3D0%26_nkw%3D" & ITEM_NUMBER_ARRAY(x) & "%26_rdc%3D1" 

     xmlHttp.Open "GET", URL, False 
     xmlHttp.setRequestHeader "Content-Type", "text/xml" 
     xmlHttp.send 


     Dim html As Object 
     Set html = CreateObject("htmlfile") 

     html.body.innerHTML = xmlHttp.ResponseText 
     Set objShipping = html.getelementbyid("shippingSection").getElementsbytagname("td")(0) 


     If Not objShipping Is Nothing Then 
      Set divShip = objShipping.ChildNodes(1) 
      Debug.Print divShip.innerHTML 
      Else 
      Debug.Print "No Data" 
     End If 

    Next 
End Sub 

立即窗口（Ctrl + G）

US $ 2.55
無數據
US $ 6.50