string - 使用 html 字符串后，VBA 查询表不会将数据拉入工作表

Question

我需要帮助，我的代码不会将数据提取到它从网站创建的新工作表中。它显示为空白。这真的很令人沮丧。在我将字符串变量“counties”分配为网站地址后，查询表将不会提取数据。我浏览了整个互联网，但没有找到如何解决这个问题的答案。

counties = Range("HTML").Offset(x, 0) 最多显示等于 08/08001.html，它是网站地址的一部分。

    Sub Macro6()

     Dim x As Integer
     Dim counties As String
     For x = 1 To 3

        Sheets("RawData").Select
        counties = Range("HTML").Offset(x, 0)
        Sheets.Add.Name = "DataTemp"

        With ActiveSheet.QueryTables.Add(Connection:="URL;http://quickfacts.census.gov/qfd/states/" & counties & ".html", Destination:=Range("$A$1"))
            .Name = "08001"
            .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 = "3,4,5"
            .WebPreFormattedTextToColumns = True
            .WebConsecutiveDelimitersAsOne = True
            .WebSingleBlockTextImport = False
            .WebDisableDateRecognition = False
            .WebDisableRedirections = False

        End With

'这部分将数据从新创建的“DataTemp”表移动到“Demographics”表中。

Columns("A:B").Select
ActiveWindow.ScrollColumn = 2
Range("A:B,D:D").Select
Range("D1").Activate
Selection.ClearContents
Range("C1:C63").Select
Selection.Copy
Sheets("Demographics").Select
Cells(6, x + 2).Select
ActiveSheet.Paste
Columns("C:C").EntireColumn.AutoFit
ActiveSheet.Previous.Select
Application.CutCopyMode = False
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True

下一个 x

结束子

Answer 1

这是对代码的快速重写，主要目的是消除对 .Select 的依赖。和 .Activate命令¹有利于直接工作表和单元格寻址。它不完整，但确实包含前三组三个表，并且应该提供一个可以构建的框架。

Sub get_County_Census_Data()

    Dim x As Long, lr As Long, nr As Long
    Dim counties As String, sURL As String

    For x = 1 To 3

        sURL = "http://quickfacts.census.gov/qfd/states/×C×.html"
        counties = Worksheets("RawData").Range("HTML").Offset(x, 0) 'e.g. 08/08001
        sURL = Replace(sURL, "×C×", counties)

        On Error GoTo bm_New_TMP_ws  'if DataTemp doesn't exist, go create one
        With Worksheets("DataTemp")
            On Error GoTo 0
            .Cells(1, 1).CurrentRegion.Clear

            With .QueryTables.Add(Connection:="URL;" & sURL, _
              Destination:=.Range("$A$1"))   'associate A1 with the DataTemp worksheet (e.g. .Range not Range)
                .Name = Right(counties, 5)  'unique name to the connection
                .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 = "3,4,5"
                .WebPreFormattedTextToColumns = True
                .WebConsecutiveDelimitersAsOne = True
                .WebSingleBlockTextImport = False
                .WebDisableDateRecognition = False
                .WebDisableRedirections = False
                .Refresh BackgroundQuery:=False
            End With

            With Worksheets("Demographics")
                nr = Application.Max(6, .Cells(Rows.Count, x + 2).End(xlUp).Offset(1, 0).Row)
            End With
            lr = .Cells(Rows.Count, 3).End(xlUp).Row
            .Cells(1, 3).Resize(lr, 1).Copy _
                Destination:=Worksheets("Demographics").Cells(nr, x + 2)
            With Worksheets("Demographics")
                .Columns(x + 2).EntireColumn.AutoFit
            End With

            'no need to retain this; delete the connection and the worksheet
            Application.DisplayAlerts = False
            .Parent.Connections(.Parent.Connections.Count).Delete
            .Delete
            Application.DisplayAlerts = True
        End With
    Next x

    GoTo bm_Safe_Exit  'skip over the worksheet creation routine

bm_New_TMP_ws:
    On Error GoTo 0
    With Worksheets.Add(After:=Sheets(Sheets.Count))
        .Name = "DataTemp"
    End With
    Resume

bm_Safe_Exit:
    '
End Sub

确实没有必要删除 数据临时 每个周期的工作表；清除数据并删除连接就足够了。但是，这演示了一种“即时”重复创建工作表的方法，这可能对学习很重要。

¹ 见 How to avoid using Select in Excel VBA macros了解更多摆脱依赖选择和激活来实现目标的方法。