0

我正在尝试读取 Sheet1 上的表值（从 A 列中的 URL 导入），然后将表值粘贴到 Sheet2 上，每个表值都在 Sheet2 上先前粘贴的 B 列中的表值正下方的行中。这些粘贴的行值通常每次都会更改（始终跨 10 列和可变的行数）。

下面的代码会将每个值 10 列粘贴到 Sheet2 的右侧，而不是粘贴到 B 列（Sheet2）和正确的行中。

任何建议都非常感谢。

以下是一些示例 URL http://hosteddb.fightmetric.com/fighters/details/994 http://hosteddb.fightmetric.com/fighters/details/993

Sub Macro2()

' Macro2 Macro

Dim WSO As Worksheet
Set WSO = ActiveSheet
Dim WS2 As Worksheet: Set WS2 = Worksheets("Sheet2")
NextRow = WS2.Range("A" & Rows.Count).End(xlUp).Row
'ctr = 1

ActiveWorkbook.Worksheets.Add

For Each cell In WSO.Range("A1:A7") 'There are over 2000 values in Column A
ThisURL = "URL;" & cell.Value
Application.CutCopyMode = False
Range("A1").Select
Selection.Copy
Application.CutCopyMode = False
Range("A1").Select
Set WS2 = ActiveSheet
With ActiveSheet.QueryTables.Add(Connection:= _
    ThisURL, Destination:=WS2.Range("A" & NextRow))
    ' Range("A$" & NextRow))    Different variations i've tested
    ' Cells(ctr + 5, 1))        Different variations i've tested
    .Name = "998"
    .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 = "9"
    .WebPreFormattedTextToColumns = True
    .WebConsecutiveDelimitersAsOne = True
    .WebSingleBlockTextImport = False
    .WebDisableDateRecognition = False
    .WebDisableRedirections = False
    .Refresh BackgroundQuery:=False
 'ctr = ctr + 1
 End With

 Next cell
 End Sub
4

1 回答 1

0

当您从 Web 插入每个新查询表时，它每次都会插入列。这就是为什么它不断将每个添加的表推到右侧。您可以使用

RefreshStyle=xlOverwriteCells

继续覆盖虚拟表上的表格（如果需要，甚至可以隐藏）。在每次覆盖之间，复制并粘贴虚拟表中的数据并将其放在所需的输出表上。我已经修改了上面的代码来做到这一点。它使用 Sheet3 作为虚拟表。

Sub copyFightStats()

Dim wsO As Worksheet
Set wsO = ActiveSheet
Dim ws2 As Worksheet: Set ws2 = Worksheets("Sheet2")
Dim ws3 As Worksheet: Set ws3 = Worksheets("Sheet3")
Dim iTableRow As Integer
Dim iTableCol As Integer
Dim iCopyRow As Integer
Dim iURLRow As Integer
Dim sURL As String
Dim xlURLRange As Range
Dim xlCell As Range

iURLRow = wsO.Range("A1").End(xlDown).Row
Set xlURLRange = wsO.Range("A1:A" & iURLRow)

For Each xlCell In xlURLRange 'There are over 2000 values in Column A

    sURL = "URL;" & xlCell.Value
    Application.CutCopyMode = False
    With ws3.QueryTables.Add(Connection:= _
        sURL, Destination:=ws3.Range("A1"))
        .Name = "998"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlOverwriteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "9"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
     End With

    'This part grabs the "length" and "width" of the imported data. Tweak this as needed
    iTableRow = ws3.Range("C1").End(xlDown).Row
    iTableCol = ws3.Range("B1").End(xlToRight).Column
    ws3.Range(Cells(1, 2).Address, Cells(iTableRow, iTableCol).Address).Copy

    If ws2.Range("b1").Value = "" Then
       iCopyRow = 1
    Else
       If ws2.Range("b2").Value = "" Then
           iCopyRow = 2
       Else
            iCopyRow = ws2.Range("b1").End(xlDown).Row + 1
       End If
    End If
    ws2.Range("A" & iCopyRow).PasteSpecial xlPasteAll

    'Clear the contents of the previously imported data before importing the next url's data
    ws3.Range(Cells(1, 2).Address, Cells(iTableRow, iTableCol).Address).ClearContents
 Next xlCell
 End Sub

让我知道这是否适合你。

于 2013-06-06T13:58:00.190 回答