VBA查詢表不會將數據拉入到它從網站創建的新工作表中，它將不會將數據拉到工作表中。

Question

我需要幫助，我的代碼不會將數據拉到它從網站創建的新工作表中。它出現爲空白。這真的令人沮喪。在我將字符串變量「縣」指定爲網站地址後，查詢表將不會提取數據。我看遍了互聯網，並沒有找到如何解決這個問題的答案。

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和.Activatecommands¹消除依賴的主要目的代碼的快速重寫。它並不完整，但確實拉入了前三組的三個表格，並且應該提供一個您可以構建的框架。

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 

實在沒有必要刪除的DataTemp工作表每個週期;清除數據並刪除連接應該足夠了。但是，這展示了一種重複創建工作表的方法，這對學習很重要。

---

¹_{見How to avoid using Select in Excel VBA macros更多的方法從依靠選擇越來越遠，並激活，以實現自己的目標。}