Извлечение данных с сайта

Question

Эта проблема слишком трудно для меня, чтобы решить, я пытался и до сих пор ничего не работает ...

Код ниже пробегает значения в колонке O и изменяет часть веб-адреса, с эти значения и затем извлекают данные в excel, но иногда, если определенный поиск не возвращает никаких результатов, я получаю ошибку 1004 и останавливается контур и не может перейти к следующему значению ...

На рисунке ниже показаны четыре значения в столбце O и сообщение об ошибке:

• О1 = N1010W
• О2 = N22NA
• О3 = N2345I
• О4 = N992AN

на значение О3, ошибка 1004 идет вверх и цикл останавливается. Есть ли способ пропустить/отменить эту ошибку и выполнить поиск в следующем (O4) значении? Поскольку данные из каждого поиска попадают в Range (A1: F1), (B2: F2) и т. Д., Когда ошибка отображается по значению O3, все ячейки в этом диапазоне (A3: F3) должны заполняться любым словом, например, «не найден»

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

Вы будете хотеть использовать On Error Resume Next. Это фактически не исправляет ошибку, но она говорит, что код будет продолжен. Я скопировал ваш код в свой листок и запустил его с помощью кода, прежде чем открывать соединение в разделе 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