VBA查询表不会拉动数据到工作表后使用string的HTML

我需要帮助，我的代码不会将数据拉到它从网站创build的新工作表中。 它出现为空白。 这真是令人沮丧。 在我将stringvariables“县”指定为网站地址后，查询表将不会拉取数据。 我看遍了互联网，还没有find如何解决这个问题的答案。

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 

'这部分将数据从新创build的“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命令的依赖.Select ，以支持直接工作表和单元寻址。 它不完整，但确实拉动了前三组三个表格，并应提供一个框架，你可以build立。

 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) 'eg 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 (eg .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 

每个周期都没有必要删除DataTemp工作表。 清除数据并删除连接应该是足够的。 但是，这展示了一种重复创build工作表的方法，这对学习很重要。

---

¹ _{请参阅如何避免使用在Excel VBAmacros中select更多的方法来摆脱依靠select和激活来实现您的目标。}