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

Question

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

这是我在执行此代码时始终打开的主要工作簿。在工作表“开始”中，我有一个表格，指定 1) 链接到应从中复制数据的工作簿 (col A)，2) 应在此主工作簿中粘贴数据的工作表范围地址 (col B)。

在我的代码中，除了将提供的链接中的所有 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

为了循环粘贴范围地址，我使用对象表。 如果能提供任何帮助，我将不胜感激！

Answer 1

如果我有一个像你这样的两列表格，这对我有用。

Split 将您的地址分成两部分，即 ! 之前的位。 （表格）和（单元格地址）之后的位，如果地址不是这种形式，则会崩溃。

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