Excel VBA-將數據複製到同一工作表中

Question

我正在嘗試讀取表Sheet1上的值（從列A中的URL導入）&然後將表格值粘貼到Sheet2上，其中的每個值位於行正下方的行中以前在Sheet2的B列中粘貼的表值。這些粘貼的行值通常會每次更改（始終跨越&變量的行數爲10列）。

下面的代碼將每個值10列粘貼到Sheet 2上的權利， 而不是進入塔B（Sheet 2中），&正確的行。

任何建議，非常感謝。

下面是一些示例網址的 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 

Answer 1

當您從網頁中插入每一個新的查詢表，它是將列各一次。這就是爲什麼它不斷將每個添加的表格推到右側。您可以使用

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 

讓我知道，如果這對你有用。