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

我在录制的宏的帮助下编写了该代码，它从网站获取某些信息，我需要自动执行该过程，点击 Button_1 后，它应循环遍历工作表（“Sheet2”）中列E的所有现有单元格值（标题除外）。我是在每个循环之间猜测它应该等到数据被完全检索和加载，那编码对我来说太过分了......

只需在每个循环运行部分的网址（ ws2.Range（“ E2 ”）。值）必须替换为Sheet2列中列的下一行ë

Answer 1

这应该这样做。

更新：我添加了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

Excel Web数据获取循环中的VBA

1 个答案: