VBA in Excel Web-Daten-Abrufschleife

Question

Sub Button1_Click() 

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

Range("A2:P100").ClearContents 

With ActiveSheet.QueryTables.Add(Connection:= _ 
"URL;http://www6.landings.com/cgi-bin/nph-search_nnr? pass=193800885&&nnumber=" & ws2.Range("E2").Value _ 
, Destination:=Range("$G$4")) 
.Name = "nph-search_nnr?pass=193800885&&nnumber=22A" 
.FieldNames = True 
.RowNumbers = False 
.FillAdjacentFormulas = False 
.PreserveFormatting = True 
.RefreshOnFileOpen = False 
.BackgroundQuery = True 
.RefreshStyle = xlInsertDeleteCells 
.SavePassword = False 
.SaveData = True 
.AdjustColumnWidth = True 
.RefreshPeriod = 0 
.WebSelectionType = xlSpecifiedTables 
.WebFormatting = xlWebFormattingNone 
.WebTables = "18" 
.WebPreFormattedTextToColumns = True 
.WebConsecutiveDelimitersAsOne = True 
.WebSingleBlockTextImport = False 
.WebDisableDateRecognition = False 
.WebDisableRedirections = False 
.Refresh BackgroundQuery:=False 

'Copy to Another sheet 

    ws.Range("I7").Copy 
    ws2.Range("A20000").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues 

    ws.Range("I8").Copy 
    ws2.Range("B20000").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues 

    ws.Range("I6").Copy 
    ws2.Range("C20000").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues 

    ws.Range("I5").Copy 
    ws2.Range("D20000").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues 



    Worksheets("Sheet2").Columns("A:P").AutoFit 



End With 

End Sub 

ich diesen Code mit Hilfe der aufgezeichneten Makro geschrieben, wird es bestimmte Informationen von der Website, Ich brauche diesen Prozess zu automatisieren und nach klicken Button_1 es sollte eine Schleife durch alle bestehenden Zelle Werte der Spalte E in Worksheets ("Sheet2") (mit Ausnahme der Kopfzeile). Ich rate zwischen jeder Schleife sollte warten, bis die Daten vollständig abgerufen und geladen werden, , dass die Codierung ist zu viel für mich noch zu behandeln .. .

Einfach in jedem geloopten Lauf Teil der Webadresse (ws2.Range ("E2 ") .Wert) muss durch die nächste Zeile in Spalte in Sheet2 Spalte ersetzt werden E

Answer 1

Dies sollte es tun.

Aktualisierung: Ich fügte Application.ScreenUpdating = False hinzu, um das Makro zu beschleunigen.

 
Option Explicit 

Sub Button1_Click() 
    Dim lastRow As Long, x As Long 

    Application.ScreenUpdating = False 

    With Worksheets("Sheet2") 

     lastRow = .Range("D" & Rows.Count).End(xlUp).Row 

     For x = 2 To lastRow 

      RequeryLandings .Cells(x, "E") 

     Next 

     .Columns("A:P").AutoFit 

    End With 

    Application.ScreenUpdating = True 

End Sub 


Sub RequeryLandings(address As String) 

    Dim ws As Worksheet 

    Set ws = ActiveWorkbook.Sheets("Sheet1") 

    Range("A2:P100").ClearContents 

    With ActiveSheet.QueryTables.Add(Connection:= _ 
            "URL;http://www6.landings.com/cgi-bin/nph-search_nnr? pass=193800885&&nnumber=" & address _ 
            , Destination:=Range("$G$4")) 
     .Name = "nph-search_nnr?pass=193800885&&nnumber=22A" 
     .FieldNames = True 
     .RowNumbers = False 
     .FillAdjacentFormulas = False 
     .PreserveFormatting = True 
     .RefreshOnFileOpen = False 
     .BackgroundQuery = True 
     .RefreshStyle = xlInsertDeleteCells 
     .SavePassword = False 
     .SaveData = True 
     .AdjustColumnWidth = True 
     .RefreshPeriod = 0 
     .WebSelectionType = xlSpecifiedTables 
     .WebFormatting = xlWebFormattingNone 
     .WebTables = "18" 
     .WebPreFormattedTextToColumns = True 
     .WebConsecutiveDelimitersAsOne = True 
     .WebSingleBlockTextImport = False 
     .WebDisableDateRecognition = False 
     .WebDisableRedirections = False 
     .Refresh BackgroundQuery:=False 

     DoEvents 

     'Copy to Another sheet 

     With Worksheets("Sheet2") 
      .Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = ws.Range("I7") 
      .Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = ws.Range("I8") 
      .Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = ws.Range("I6") 
      .Range("D" & Rows.Count).End(xlUp).Offset(1, 0) = ws.Range("I5") 
     End With 
    End With 

End Sub