CODEWITHSUNDEEP
excelwebfetchvba
FotoDJ
FotoDJ

Reputation: 351

Fetching data from website

This problem is too difficult for me to solve, I've tried and so far nothing works...

The code below runs through values in Column O and changes part of a web address with that values and then fetch the data into excel but sometimes if the certain search returns no results then I am getting error 1004 and loop stops and can not go to next value...

Picture below shows four values in Column O and error message:

enter image description here

on the value O3, error 1004 comes up and loop stops. Is there a way to skip/cancel that error and have the search go to next (O4) value ? Because data from every search goes into Range (A1:F1), (B2:F2) and so on when error shows up by O3 value, the allcells in that Range(A3:F3) should be filled with any word, for example, "not found" 

Option Explicit

 Sub Getdata()



Dim lastrow As Long, x As Long

Application.ScreenUpdating = False


 With Worksheets("Sheet2")

    lastrow = .Range("O" & Rows.Count).End(xlUp).Row

    For x = 2 To lastrow



        RequeryLandings .Cells(x, "O")

    Next

End With

Application.ScreenUpdating = True

End Sub

Sub RequeryLandings(address As String)

Dim ws As Worksheet



Dim NewRow As Long

With Worksheets("Sheet2")
Set ws = ActiveWorkbook.Sheets("Sheet1")




   With ws.QueryTables.Add(Connection:= _
    "URL;http://www.airport-data.com/aircraft/" & address & ".html",            Destination:=ws.Range( _
    "$A$1"))
    .Name = "N1010W"
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = False
    .RefreshOnFileOpen = False
    .BackgroundQuery = True
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .WebSelectionType = xlSpecifiedTables
    .WebFormatting = xlWebFormattingAll
    .WebTables = "2"
    .WebPreFormattedTextToColumns = True
    .WebConsecutiveDelimitersAsOne = True
    .WebSingleBlockTextImport = False
    .WebDisableDateRecognition = False
    .WebDisableRedirections = False
    .Refresh BackgroundQuery:=False

    End With
     Range("A14").Select
With ws.QueryTables.Add(Connection:= _
    "URL;http://www.airport-data.com/aircraft/" & address & ".html",      Destination:=Sheets("Sheet1").Range( _
    "$A$12"))
    .Name = "N1010W_2"
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = False
    .RefreshOnFileOpen = False
    .BackgroundQuery = True
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .WebSelectionType = xlSpecifiedTables
    .WebFormatting = xlWebFormattingAll
    .WebTables = "3"
    .WebPreFormattedTextToColumns = True
    .WebConsecutiveDelimitersAsOne = True
    .WebSingleBlockTextImport = False
    .WebDisableDateRecognition = False
    .WebDisableRedirections = False
    .Refresh BackgroundQuery:=False

End With



    DoEvents



    Dim strSplit() As String
Dim cell As Range



For Each cell In ws.Range("B2:B200")

If (cell.Value <> vbNullString) Then

    cell.Value = Split(cell.Value, "   Search")(0)

End If

Next cell



End With


    'Copy to Another Sheet

 With Worksheets("Sheet2")
NewRow = .Range("D" & Rows.Count).End(xlUp).Row + 1


If ws.Range("A54") = "Notice:" Then
    Sheets("Sheet1").Range("A54:A55").EntireRow.Delete
End If

.Range("A" & NewRow) = ws.Range("B1")
.Range("B" & NewRow) = ws.Range("B2")
.Range("C" & NewRow) = ws.Range("B4")
.Range("D" & NewRow) = ws.Range("B12")
.Range("E" & NewRow) = ws.Range("B3")


  If ws.Range("A14") = "Certification Class:" Then
 .Range("F" & NewRow) = ws.Range("B14")
  Else
     .Range("F" & NewRow) = "Unknown"
 End If



    End With





   ActiveWorkbook.Sheets("Sheet1").Range("A1:P100") = Null

   Sheets("Sheet2").Activate

   Sheets("Sheet2").Range("G1").Select




  End Sub

Upvotes: 0

Views: 104

Answers (1)

PartyHatPanda
PartyHatPanda

Reputation: 724

You are going to want to use On Error Resume Next. This doesn't actually fix the error, but it does tell the code to continue. I copied your code into my sheet and ran it with the code snip before you open the connection in the sub RequeryLandings.

'The Error line, after you set ws = activeWorkbook.Sheets("Sheet1")
On Error Resume Next

With ws.QueryTables.Add(Connection:= _
"URL;http://www.airport-data.com/aircraft/" & address & ".html", Destination:=ws.range( _
"$A$1"))
.Name = "N1010W"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingAll
.WebTables = "2"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False

End With

Upvotes: 1

Related Questions