The code below cycles through a list of approx 2800 numbers in excel, copies the accociated web page to another worksheet then performs calcs before copying results back onto intial worksheet
All worked fine until a few weeks ago, now the code only copies the webpages intermittently. It sometimes works ok for the first 50 or so then stops. Never the same number on the list either
it's something to do with this section I think
I can't work it out what is wrong - anyone any clues?
Code and working attachment are enclosed
All worked fine until a few weeks ago, now the code only copies the webpages intermittently. It sometimes works ok for the first 50 or so then stops. Never the same number on the list either
it's something to do with this section I think
Code:
With ActiveSheet.QueryTables.Add(Connection:="URL;[URL unfurl="true"]http://www.discogs.com/sell/list?release_id="[/URL] & release_id.Value, _
Destination:=Range("a3")) 'write web-page to sheet
I can't work it out what is wrong - anyone any clues?
Code and working attachment are enclosed
Code:
Sub Discog_Extract()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Dim USD As Currency
Dim EUR As Currency
Dim GBP As Currency
Dim MaxPrice As Currency
Dim MinPrice As Currency
Dim AvgPrice As Currency
Dim countrecords As Long
Dim release_id As Range
Dim theRange As Range
EUR = 0.695532 ' Set exchange rates for your country - your own currency should equal 1
USD = 0.480307 ' Set exchange rates for your country - your own currency should equal 1
GBP = 1 ' Set exchange rates for your country - your own currency should equal 1
Worksheets("items").Activate
With ActiveSheet
For Each release_id In Intersect(.UsedRange, .Range("e1:e2802"))
On Error Resume Next
If release_id.Value = "" Then Exit Sub
If release_id.Value = "release_id" Then
Worksheets("items").Activate
release_id.Offset(0, 8) = "MaxPrice"
release_id.Offset(0, 9) = "MinPrice"
release_id.Offset(0, 10) = "AvgPrice"
release_id.Offset(0, 11) = "Number on Sale"
release_id.Offset(0, 12) = "Data Extracted on"
Else
Worksheets("Web download").Activate
Range("A:z").Select
Selection.ClearContents
Selection.ClearFormats
With ActiveSheet.QueryTables.Add(Connection:="URL;[URL unfurl="true"]http://www.discogs.com/sell/list?release_id="[/URL] & release_id.Value, _
Destination:=Range("a3")) 'write web-page to sheet
.BackgroundQuery = True
.TablesOnlyFromHTML = False
.Refresh BackgroundQuery:=False
.SaveData = True
End With
Set theRange = Range("d:d")
Dim c As Range
For Each c In theRange
If (c.Offset(3, -2)) = "Media Condition: Near Mint (NM or M-)" Then
'MsgBox (c.Offset(3, -2))
If Val(c) > 0 Then c.Offset(0, 1) = Val(c) * EUR
c.Offset(0, 2) = Left(c.NumberFormat, 1) ' test number format remove from final version
Select Case Left(c, 1)
Case "€": c.Offset(0, 1) = Val(Mid(c, 3)) * EUR
Case "$": c.Offset(0, 1) = Val(Mid(c, 3)) * USD
Case "£": c.Offset(0, 1) = Val(Mid(c, 3)) * GBP
End Select
Select Case Left(c.NumberFormat, 1)
Case "$": c.Offset(0, 1) = Val(c) * GBP
End Select
End If
If (c.Offset(3, -2)) = "Media Condition: Mint (M)" Then
'MsgBox (c.Offset(3, -2))
If Val(c) > 0 Then c.Offset(0, 1) = Val(c) * EUR
c.Offset(0, 2) = Left(c.NumberFormat, 1) ' test number format remove from final version
Select Case Left(c, 1)
Case "€": c.Offset(0, 1) = Val(Mid(c, 3)) * EUR
Case "$": c.Offset(0, 1) = Val(Mid(c, 3)) * USD
Case "£": c.Offset(0, 1) = Val(Mid(c, 3)) * GBP
End Select
Select Case Left(c.NumberFormat, 1)
Case "$": c.Offset(0, 1) = Val(c) * GBP
End Select
End If
Next
Set theRange = Range("E:E")
MaxPrice = Application.Max(theRange)
MinPrice = Application.Min(theRange)
AvgPrice = Application.Average(theRange)
countrecords = Application.count(theRange)
Worksheets("items").Activate
If countrecords > 0 Then
release_id.Offset(0, 8) = MaxPrice
release_id.Offset(0, 9) = MinPrice
release_id.Offset(0, 10) = AvgPrice
release_id.Offset(0, 11) = countrecords
release_id.Offset(0, 12) = Now()
End If
'MsgBox MaxPrice & " " & MinPrice & " " & AvgPrice & " " & countrecords
End If
Next release_id
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub