从 link 地址复制工作簿并将其粘贴到范围地址

Question

我正在尝试编写代码，根据我主工作簿中的 link 地址，从另一个工作簿复制特定 sheet 的内容。然后，它应该将其粘贴到我的主工作簿中的 sheet 范围，该范围也作为范围地址提供。这必须在循环中执行，因为我想对存储在不同 link 下的其他 2 个工作簿重复它。存储在不同 link 下的所有这 3 个工作簿都具有名为 'Data' 的 sheet，必须将其粘贴到我的主工作簿中。

这是我在执行这段代码时总是打开的主要工作簿。在 sheet 'Start' 中，我有 table 指定 1) Link 到应从中复制数据的工作簿（A 列），2) Sheet应将数据粘贴到此主工作簿中的范围地址（B 列）。

在我的代码中，除了将所提供的 link 中的所有 3 个工作簿的内容粘贴到 'Sheet1'!A1 之外，其他都可以。我尝试 F8 代码，看起来代码在 B 列中没有正确循环。

Sub Copy_Paste()

Dim Ws_MainWS As Worksheet
Dim intFirstRow_Ws2 As Integer
Dim intLastCol_Ws2 As Integer
Dim ActiveWs As Variant
Dim Var_Ws2Link As Variant
Dim intListRow As Integer
Dim intListRow_Paste As Integer
Dim objTable As Excel.ListObject
Dim objRange As Excel.Range
Dim intLastRow_Ws1Tbl As Integer

Set Ws_MainWS = ThisWorkbook.Sheets("Start")
Set ActiveWs = ActiveWorkbook
Set objTable = Ws_MainWS.ListObjects("tblStart")

intLastRow_Ws1Tbl = Ws_MainWS.Cells(Rows.Count, 1).End(xlUp).row
intFirstRow_Ws2 = 1
Const ColumnStart As Integer = 1

On Error GoTo ErrorHandler

'Copy and Paste into provided sheet range address
    'Loop through Links to other workbooks
    For intListRow = 3 To intLastRow_Ws1Tbl
        Set Var_Ws2Link = Ws_MainWS.Cells(intListRow, 1)

            With objTable
                'Loop through pasting range addresses and paste
                For intListRow_Paste = 1 To .DataBodyRange.Rows.Count
                    Set objRange = Excel.Range(.DataBodyRange(intListRow_Paste, .ListColumns("Sheet Range address").Index).Value)
                         Workbooks.Open Var_Ws2Link, local:=True
                         intLastCol_Ws2 = Worksheets("Data").Cells(1, Columns.Count).End(xlToLeft).Column
                        With Worksheets("Data")
                            .Range(.Cells(intFirstRow_Ws2, ColumnStart), .Cells(.Rows.Count, intLastCol_Ws2)).Copy
                            objRange.PasteSpecial xlPasteValues
                            Application.CutCopyMode = False
                            Set objRange = Nothing
                            ActiveWorkbook.Close
                        End With

                    Exit For

                Next intListRow_Paste
            End With

            Set objTable = Nothing

    Next intListRow

MsgBox "Done"


Exit Sub
ErrorHandler:

Set objTable = Nothing

End Sub

为了遍历粘贴范围地址，我使用对象 table。如有任何帮助，我将不胜感激！

Answer 1

如果我有像您一样的两列 table，这对我有用。

Split 将您的地址一分为二，即 ! 之前的位(sheet) 和 (cell address) 之后的位，所以如果地址不是这种形式就会崩溃。

Sub x()

Dim r As Range, t As ListObject, wb As Workbook, v As Variant

Set t = Worksheets(1).ListObjects("Table1")

For Each r In t.ListColumns(1).DataBodyRange 'loop through column 1
    Set wb = Workbooks.Open(r.Value)         'open workbook
    v = Split(r.Offset(, 1).Value, "!")      'split cell in 2nd column
    wb.Worksheets(1).Range("A1").Copy ThisWorkbook.Worksheets(replace(v(0),"'","")).Range(v(1))        'paste
    wb.Close False
Next r

End Sub

从 link 地址复制工作簿并将其粘贴到范围地址

Copy workbooks from the link addresses and paste it in to the range address

excel

vba

copy-paste