Abfragen von Daten von der Website

Question

Dieses Problem ist zu schwierig für mich zu lösen, ich habe versucht, und bisher nichts funktioniert ...

Der Code unten durch Werte in Spalte A läuft und ändert Teil einer Web-Adresse mit die Werte und dann die Daten in Excel abrufen, aber manchmal, wenn die bestimmte Suche keine Ergebnisse zurückgibt, bekomme ich Fehler 1004 und Schleife stoppt und kann nicht zum nächsten Wert gehen ...

Bild unten zeigt vier Werte in Spalte O und Fehlermeldung:

• O1 = N1010W
• O2 = N22NA
• O3 = N2345I
• O4 = N992AN

auf dem Wert O3, Fehler 1004 kommt und Schleife stoppt. Gibt es eine Möglichkeit, diesen Fehler zu überspringen/abzubrechen und die Suche zum nächsten (O4) Wert zu führen? Da Daten von jeder Suche in den Bereich (A1: F1), (B2: F2) und so weiter gehen, wenn der Fehler durch den O3-Wert angezeigt wird, sollten die Allzellen in diesem Bereich (A3: F3) mit einem beliebigen Wort gefüllt werden. „nicht gefunden“

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 

Answer 1

Sie werden On Error Resume Next verwenden wollen. Dies behebt den Fehler zwar nicht, aber der Code wird fortgesetzt. Ich habe deinen Code in mein Arbeitsblatt kopiert und ihn mit dem Code-Snip ausgeführt, bevor du die Verbindung in den Unter-RequeryLandings öffnest.

'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