LinkBack URL
About LinkBacks
I have this macro code , It works fine but while it is running internet explorer pops up all the time, Can anyone help to stop is popping up?
I have attached the sheet .Reviews Mapping.xlsm
I have this macro code , It works fine but while it is running internet explorer pops up all the time, Can anyone help to stop is popping up?
I have attached the sheet .Reviews Mapping.xlsm
Last edited by pari9485; 10-09-2013 at 01:24 PM.
Try changing the code that deals with the HTML to this, which works.
Set htmlDoc = CreateObject("htmlfile") htmlDoc.body.innerhtml = PageSrc For Each htmlSpan In htmlDoc.getElementsByTagName("span") If htmlSpan.ClassName = "partner-reviews-count" Then If htmlSpan.NodeType = 1 Then GetReviewsCount = Val(htmlSpan.innerhtml) Exit Function End If End If Next htmlSpan GetReviewsCount = "No Review"
Last edited by Norie; 10-09-2013 at 03:21 PM.
If posting code please use code tags, see here.
Hello pari9485,
I found the problem!
The authors of the web page made a mistake in the code. The problem is with the placement of a META tag in the code. This tag tells Internet Explorer which version to use. Since it is in the wrong place, Internet Explorer defaults to version 7. Here are the updated macros. The attached file has them added.
Function GetReviewsCount(ByVal URL As String) As Variant Dim htmlDoc As Object Dim htmlSpan As Object Dim i As Long Dim metTag As String Dim PageSrc As String With CreateObject("MSXML2.XMLHTTP") .Open "GET", URL, True .Send While .readyState <> 4: DoEvents: Wend ' Check for any connection errors. Put the error info in cells A4:B4. If .statusText <> "OK" Then MsgBox "ERROR " & .Status & " - " & .statusText, vbExclamation Exit Function End If PageSrc = .ResponseText End With i = InStr(1, PageSrc, "<head>", vbTextCompare) If i = 0 Then Exit Function metaTag = " <meta http-equiv=""X-UA-Compatible"" content=""IE=edge,chrome=1""> " PageSrc = Left(PageSrc, i + 5) & metaTag & Right(PageSrc, Len(PageSrc) - i - 5) ' Create an empty HTML Document and load it with the PageSource. Set htmlDoc = CreateObject("htmlfile") htmlDoc.Open ' NOTE: This will check if cookies are enabled and prompt you if they aren't. htmlDoc.write PageSrc ' Close the file for writing. htmlDoc.Close While htmlDoc.readyState <> "complete": DoEvents: Wend For Each htmlSpan In htmlDoc.getElementsByTagName("span") If htmlSpan.ClassName = "partner-reviews-count" Then If htmlSpan.NodeType = 1 Then GetReviewsCount = Val(htmlSpan.innerHTML) Exit Function End If End If Next htmlSpan GetReviewsCount = "No Review" End Function Sub Macro1() Dim Cell As Range Dim EndRow As Long Dim Rng As Range Dim Wks As Worksheet Set Wks = ActiveSheet Set Rng = Wks.Range("A2") EndRow = Wks.Cells(Rows.Count, "A").End(xlUp).Row If EndRow < Rng.Row Then Exit Sub Else Set Rng = Rng.Resize(EndRow - Rng.Row + 1, 1) For Each Cell In Rng DoEvents Cell.Offset(0, 1) = GetReviewsCount(Cell) Next Cell MsgBox "Finished checking reviews." End Sub
Sincerely,
Leith Ross
Remember To Do the Following....
1. Use code tags. Place [CODE] before the first line of code and [/CODE] after the last line of code.2. Thank those who have helped you by clicking the Starbelow the post.
3. Please mark your post [SOLVED] if it has been answered satisfactorily.
Old Scottish Proverb...
Luathaid gu deanamh maille! (Rushing causes delays!)
Wow, this is awesome, now I can finish my work in minutesThanks a lot .
pari9485
Just curious, did you try what I suggested?
the code which you gave didn't help to solve the problem , but i got the solution. Thanks for the help
Last edited by pari9485; 10-10-2013 at 11:51 AM.
I more thing I wanted to ask, If I want to alter this code so that it can take reviews from other websites for eg : http://www.amazon.in/dp/B00CE2LQSW . How can it be done?
..........................................................................................
Hello pai9485,
I have modified the macro to recognize the URL Amazon India. If present it will extract the review count. Here is the mdified code. The attached workbook contains the change;
Function GetReviewsCount(ByVal URL As String) As Variant Dim htmlDoc As Object Dim htmlSpan As Object Dim i As Long Dim metTag As String Dim PageSrc As String With CreateObject("MSXML2.XMLHTTP") .Open "GET", URL, True .Send While .readyState <> 4: DoEvents: Wend ' Check for any connection errors. Put the error info in cells A4:B4. If .statusText <> "OK" Then MsgBox "ERROR " & .Status & " - " & .statusText, vbExclamation, URL Exit Function End If PageSrc = .ResponseText End With i = InStr(1, PageSrc, "<head>", vbTextCompare) If i = 0 Then Exit Function metaTag = " <meta http-equiv=""X-UA-Compatible"" content=""IE=edge,chrome=1""> " PageSrc = Left(PageSrc, i + 5) & metaTag & Right(PageSrc, Len(PageSrc) - i - 5) ' Create an empty HTML Document and load it with the PageSource. Set htmlDoc = CreateObject("htmlfile") htmlDoc.Open ' NOTE: This will check if cookies are enabled and prompt you if they aren't. htmlDoc.write PageSrc ' Close the file for writing. htmlDoc.Close While htmlDoc.readyState <> "complete": DoEvents: Wend If URL Like "http://www.amazon.in/*" Then Set Div = htmlDoc.getElementById("averageCustomerReviewCount") If Not Div Is Nothing Then GetReviewsCount = Val(Div.ChildNodes(0).ChildNodes(0).NodeValue) Exit Function Else GoTo NoReviews End If End If For Each htmlSpan In htmlDoc.getElementsByTagName("span") If htmlSpan.ClassName = "partner-reviews-count" Then If htmlSpan.NodeType = 1 Then GetReviewsCount = Val(htmlSpan.innerHTML) Exit Function End If End If Next htmlSpan NoReviews: GetReviewsCount = "No Review" End Function
Hi Mr.Ross , Although the code is working for Amazon India, but it is not able to detect some of the pages. Some of the pages having reviews are answered as "No review". I have marked them as yellow.Please have a look.
Thanks
Pari
There are currently 1 users browsing this thread. (0 members and 1 guests)
Posting Permissions
Register To Reply
Bookmarks