How to check that an hyperlink is valid

[Jean]

Hi,

I try to fetch data from a web site but some of the target id do not exist therefore i get an error message. In fact i want to skip this error message and go to next target id. It seems that something is wrong with my code. Any suggestions ?

Thanks !

Sub MacroAZ()
Dim Enterprise As Long
Dim Page As Integer
Dim Cell As Integer
Dim Cell2 As Integer
Dim NxtCell As Integer
Dim CellContent As String
Dim lngErrNumber As Long
Cell = 1
For Enterprise = 100000 To 200000
On Error GoTo Error_MacroAZ
ActiveWorkbook.FollowHyperlink Address:="http://www.thomasregional.com/heading.html?y=TH10438621555055&us=3e4456cfe7b5f&heading=581&panel=P23e4456cfddf28&pub=10&acct=" & Enterprise & ""
Sheets("Sheet2").Range("D2").Value = Enterprise
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://www.thomasregional.com/heading.html?y=TH10438621555055&us=3e4456cfe7b5f&heading=581&panel=P23e4456cfddf28&pub=10&acct=" & Enterprise & "", Destination:=Sheets("Sheet2").Range("A" & Cell & ""))
.Name = "rirekiv2"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebTables = "8"
.WebFormatting = xlNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.Refresh BackgroundQuery:=True

End With
If Sheets("Sheet2").Range("A1") <> "" Then
CellContent = Sheets("Sheet2").Range("A1").Value
If CellContent Like "[rirekiv]*" Then
Else
Worksheets("Contacts").Rows(2).Insert
Worksheets("Companies").Rows(2).Insert
Sheets("Sheet2").Range("A1").Copy
ActiveSheet.Paste Destination:=Worksheets("Companies").Range("B2")
If Sheets("Sheet2").Range("A2") <> "" Then
Sheets("Sheet2").Range("A2").Copy
ActiveSheet.Paste Destination:=Worksheets("Companies").Range("D2")
End If
If Sheets("Sheet2").Range("A3") <> "" Then
Sheets("Sheet2").Range("A3").Copy
ActiveSheet.Paste Destination:=Worksheets("Companies").Range("E2")
End If
For Cell2 = 4 To 20
NxtCell = 0
CellContent = Sheets("Sheet2").Range("A" & Cell2 & "").Value
If CellContent Like "[Phone]*" Then
Sheets("Sheet2").Range("A" & Cell2 & "").Copy
ActiveSheet.Paste Destination:=Worksheets("Companies").Range("L2")
ElseIf CellContent Like "[Fax:]*" Then
Sheets("Sheet2").Range("A" & Cell2 & "").Copy
ActiveSheet.Paste Destination:=Worksheets("Contacts").Range("K2")
ElseIf CellContent Like "[Web Site:]*" Then
Sheets("Sheet2").Range("A" & Cell2 & "").Copy
ActiveSheet.Paste Destination:=Worksheets("Companies").Range("J2")
ElseIf CellContent Like "[Contacts:]*" Then
NxtCell = Cell2 + 1
Sheets("Sheet2").Range("A" & NxtCell & "").Copy
ActiveSheet.Paste Destination:=Worksheets("Contacts").Range("D2")
ElseIf CellContent Like "[Company Description:]*" Then
NxtCell = Cell2 + 1
Sheets("Sheet2").Range("A" & NxtCell & "").Copy
ActiveSheet.Paste Destination:=Worksheets("Companies").Range("K2")
End If
Next
End If
End If
Sheets("Sheet2").Range("A1:A25").Clear
GoTo Suivant
Error_MacroAZ:
lngErrNumber = Err.Number
Select Case lngErrNumber

Case -2146697208
lngErrNumber = 0
Err.Number = 0
GoTo Suivant
End Select
Suivant:
Next
End Sub

 

[Celeda]

Bonsoir, Hi,

Nice to meet you Jean.

I just would like to draw your attention about this Forum : it is a French Forum.
Sometimes we speak both, French or anything !.

Nevertheless, all the guys here understand English of course !!! The procedures are in English.
For your next requests, if you speak French you can write your text in French. If not, we will try to translate your problems.

Unfortunately, concerning your request I can't help you.When VBA Masters visit the site, may be, they will help you.

Thanks for your understanding and Have a good week-end.

Celeda

 

[@+Thierry]

Hi Jean

Have just looked at your code. Yes its really wrong !! Two times it crashed fully my PC with hundreds IE windows poping up every where from the WebSite Thomas...

Thanks a lot for the fun !

Bye
@+Thierry