Hi Maruti,
Please Replace original code with below one I believe this will solve your problem:
Code:
Public Sub InkWeb()
Dim MyPost As String
Dim MyUrl As String
Dim PostUser As String
Dim PostPassword As String
Dim wbkTemp As Workbook
Dim strPrice As String
Dim strShipChar As String
Dim IEwindow As SHDocVw.InternetExplorer
Dim allExplorerWindows As New SHDocVw.ShellWindows
Dim rngPaste As Range
Dim rngPrice As Range
Dim rngShipping As Range
Dim rngBML As Range
Application.ScreenUpdating = False
Set allExplorerWindows = New SHDocVw.ShellWindows
For Each IEwindow In allExplorerWindows
MyUrl = IEwindow.LocationURL
If InStr(1, MyUrl, "ebay") > 0 Then
Set wbkTemp = Workbooks.Add(1)
With wbkTemp.Worksheets("sheet1").QueryTables.Add(Connection:="URL;" & MyUrl, Destination:=Cells(5, 1))
.PostText = MyPost
.BackgroundQuery = True
.TablesOnlyFromHTML = True
.Refresh BackgroundQuery:=False
.SaveData = True
End With
With wbkTemp.Worksheets("Sheet1")
Set rngPrice = .Cells.Find("Price:", , , xlWhole)
strPrice = rngPrice.Offset(, 1)
On Error Resume Next
Set rngShipping = .Cells.Find("Shipping:", , , xlWhole)
'Set rngBML = .Cells.Find("Bill Me Later", , , xlPart)
strShipChar = rngShipping.Offset(, 1)
On Error GoTo 0
End With
wbkTemp.Close 0
Set wbkTemp = Nothing
With ThisWorkbook.Worksheets("FetchData")
If .Range("rngPrice").Value <> "" Then
If .Range("rngPrice").End(xlDown).Row <> .Rows.Count Then
Set rngPaste = .Range("rngPrice").End(xlDown).Offset(1)
Else
Set rngPaste = .Range("rngPrice").Offset(1)
End If
rngPaste.Value = strPrice
rngPaste.Offset(, 1).Value = strShipChar
Else
MsgBox "Please set the Header ""Price"" in Cell B6", vbInformation
Exit Sub
End If
End With
End If
Next
Application.ScreenUpdating = True
End Sub
Bookmarks