VBA在Excel Web數據獲取循環

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

我寫了錄製宏的幫助，代碼，它獲取某些信息從網站，我需要自動執行該過程，然後單擊Button_1它應該遍歷所有現有的後E列工作表（「Sheet2」）（除了標題）的單元格值。我猜測每個循環之間它應該等待，直到數據完全檢索和加載，編碼太多，我無法處理。VBA在Excel Web數據獲取循環

只需在網址的每個循環運行部分（）ws2.Range（「E2「）。值）必須替換爲Sheet2列中列的下一行E

來源

2016-07-10 FotoDJ

我無法測試我的解決方案，但它應該可以工作。讓我知道它是怎麼回事，如果我們需要調整它。 –

對不起，我應該抓住那個。我將「Option Explicit」添加到代碼模塊的頂部。這會強制變量聲明並使其更容易調試宏。現在已經修復了。 –

這應該這樣做。

更新：我加了Application.ScreenUpdating = False來加速宏。

 
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

來源

2016-07-10 01:42:17

經過測試，一切正常，謝謝Thomas Inzina！ – FotoDJ

真棒，高興地幫助。 –

VBA在Excel Web數據獲取循環

回答

相關問題