Question

我知道标题可能不太清楚。基本上，我有这个代码。它正在导入我想要的数据，但它正在取桌并将它们并排放在Excel工作表中。因此每个表都是一定数量的行和一列。但是，我希望这样做更改，以便导入的表被堆叠，因此它们都在同一列中。

Sub Macro1()
       Dim startDate As Date
       Dim thisDate As Date
       Dim endDate As Date
       Dim str2 As String
       Dim str1 As String
       Dim str3 As String
       Dim str As String
       Dim i As Integer

    startDate = DateSerial(2004, 1, 1)
    endDate = DateSerial(2016, 4, 1)
    str1 = "URL;https://www.census.gov/construction/bps/txt/tb3u"
    str3 = ".txt"

    For i = 1 To 300
        thisDate = DateAdd("m", i, startDate)
        str2 = Format(thisDate, "yyyyMM")
        str = str1 & str2 & str3

         With ActiveSheet.QueryTables.Add(Connection:= _
      str, _
         Destination:=Range("a1"))
        .Name = "erich."
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
      End With
    Next i
End Sub

Answer 1

在Jeeped评论之后

编辑

查看'<===评论

的行

Option Explicit

Sub Macro1()
   Dim startDate As Date
   Dim thisDate As Date
   Dim endDate As Date
   Dim str2 As String
   Dim str1 As String
   Dim str3 As String
   Dim str As String
   Dim i As Integer

startDate = DateSerial(2004, 1, 1)
endDate = DateSerial(2016, 4, 1)
str1 = "URL;https://www.census.gov/construction/bps/txt/tb3u"
str3 = ".txt"

For i = 1 To 300
    thisDate = DateAdd("m", i, startDate)
    str2 = Format(thisDate, "yyyyMM")
    str = str1 & str2 & str3

     With ActiveSheet.QueryTables.Add(Connection:= _
  str, _
     Destination:=Range("a" & Rows.Count).End(xlUp)).offset(1) '<=== also edited to skip one row down
    .name = "erich."
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .BackgroundQuery = True
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .WebSelectionType = xlEntirePage
    .WebFormatting = xlWebFormattingNone
    .WebPreFormattedTextToColumns = True
    .WebConsecutiveDelimitersAsOne = True
    .WebSingleBlockTextImport = False
    .WebDisableDateRecognition = False
    .WebDisableRedirections = False
    .RefreshStyle = xlOverwriteCells '<===
    .Refresh BackgroundQuery:=False

  End With
Next i
Activesheet.rows(1).delete '<== added in editing. removes first row that has been left empty after the first iteration
End Sub

Answer 2

为循环的每次迭代调整A列中的目标行。

Sub Macro1()
   Dim startDate As Date, thisDate As Date, endDate As Date
   Dim str As String, str1 As String, str2 As String, str3 As String
   Dim i As Long, rw As Long

    startDate = DateSerial(2004, 1, 1)
    endDate = DateSerial(2016, 4, 1)
    str1 = "URL;https://www.census.gov/construction/bps/txt/tb3u"
    str3 = ".txt"

    For i = 1 To 300
        thisDate = DateAdd("m", i, startDate)
        str2 = Format(thisDate, "yyyyMM")
        str = str1 & str2 & str3
        rw = Range("a" & Rows.Count).End(xlUp).Row - Int(i > 1)  'Adjust the destination row
         With ActiveSheet.QueryTables.Add(Connection:=str, Destination:=Range("a" & rw))   'new destination row each loop
            .Name = "erich."
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .BackgroundQuery = True
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .WebSelectionType = xlEntirePage
            .WebFormatting = xlWebFormattingNone
            .WebPreFormattedTextToColumns = True
            .WebConsecutiveDelimitersAsOne = True
            .WebSingleBlockTextImport = False
            .WebDisableDateRecognition = False
            .WebDisableRedirections = False
            .Refresh BackgroundQuery:=False
        End With
        'you might want to get rid of the last connection
        ActiveWorkbook.Connections.Item(ActiveWorkbook.Connections.Count).Delete
    Next i

    'you might want to get rid of all repeated connections
    With ActiveWorkbook.Connections
        Do While CBool(.Count)
            .Item(.Count).Delete
        Loop
    End With
End Sub

我添加了一些可选代码，用于删除数据，创建连接或在检索完所有内容后循环显示。

使用VBA垂直非水平地将数据从网站导入工作表

2 个答案: