Excel 2010 VBA를 통해 이베이 배송료를 다운로드해야합니까?

Question

나는 eBay에서 무료 배송료를 무료로 다운로드하려고 노력 해왔다. 페이지의 항목 번호가 있습니다. 링크는 eBay의 올바른 페이지로 이동해야합니다. 페이지로 이동하여 데이터를 다운로드하려고 시도하는 동안 Excel이 중지되고 절대로 복구되지 않습니다. 나는이 선적료를 정말로 필요로하고 근본적으로 시간이 없다. 이 코드가 멈추지 않는 문제를 해결할 수 없다면 누군가 Excel에 필요한 정보를 얻는 방법을 알려주실 수 있습니까? 나는 이베이에서 많은 페이지의 이베이 항목 번호를 얻는 다른 코드를 가지고 있는데,이 코드는이 코드와 매우 흡사합니다.

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 

기존 코드를 계속 사용하는 경우 쿼리 후 쿼리 테이블을 삭제 해 볼 수도 있습니다.

Dim QRY_TABLE As QueryTable 

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

이 방법으로는 스프레드 시트의 쿼리 테이블 값이 삭제되지 않지만 쿼리 가능 연결은 종료됩니다. 이것들이 너무 많으면 충돌이 발생할 수 있습니다.

통합 문서에 vlookups이 많이 포함되어 있으면 마지막으로 제안 할 것이 있습니다. 이것이 아마도 진정한 원인 일 것입니다. 행운을 빕니다!

Answer 2

데이터를 쉽게 다운로드 할 수있는 xmlHTTP 객체를 사용할 수 있으며 엑셀이 제대로 작동하지 않습니다.

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)

미국 $ 2.55
데이터 없음
US $ 6.50

나는이 모든 코드, 생각하지 않습니다