Question

请修改我的代码，以便它可以工作，我在excel表中有一个网址列表，我想使用基于该列表的网页查询并在新表格中提取数据，需要一个宏代码。< / p>

Dim wb As Workbook
Dim src As Worksheet
Dim tgt As Worksheet

Set wb = ThisWorkbook
Set src = wb.Sheets("Sheet2")
Set tgt = wb.Sheets("Sheet17")
Dim row As Long
For row = 6 To 15
Cells(row, 12).Value = Cells(row, 12)
Do While src.Cells(row, 12) <> “”
Dim url As String
url = Cells(row, 12)
Range("A1").Select
ActiveWindow.SmallScroll Down:=1
With ActiveSheet.QueryTables.Add(Connection:= _
    url, Destination:=Range("$A$5"))
    .CommandType = 0
    .Name = "spg-20161231x10k.htm#Item8FinancialStatementsandSupplementary_1"
    .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 = "300"
    .WebPreFormattedTextToColumns = True
    .WebConsecutiveDelimitersAsOne = True
    .WebSingleBlockTextImport = False
    .WebDisableDateRecognition = False
    .WebDisableRedirections = False
    .Refresh BackgroundQuery:=False
End With

Answer 1

我已经为我的测试更改了表参数，但是这个结构可以工作：

Option Explicit
Public Sub GenerateQryTables()

    Dim wb As Workbook, src As Worksheet, url As String, currentRow As Long

    Application.ScreenUpdating = False
    Set wb = ThisWorkbook
    Set src = wb.Worksheets("Sheet2")

    With src
        For currentRow = 6 To 15
            DoEvents
            url = .Cells(currentRow, 12)
            If url <> vbNullString Then
                Sheets.Add
                With ActiveSheet.QueryTables.Add(Connection:= _
      "URL;" & url, _
         Destination:=Range("A5"))

                    .Name = "Query" & currentRow
                    .FieldNames = True
                    .FieldNames = True
                    .WebSelectionType = xlAllTables
                    .Refresh BackgroundQuery:=False
                End With
            End If
        Next currentRow
    End With
    Application.ScreenUpdating = True
End Sub

在VBA代码中使用excel的Web地址列表来使用带循环的动态Web查询

1 个答案: