Question

我有一个包含3列的工作表：URL-目标工作表-行

URL会将您定向到自动下载的.XLS文件（以下示例）：

http://www.eurexrepo.com/blob/157370/ccb5c831da64925cfc15aff4c5e4be85/data/euro_gjpbasket.xls

我想做的是让VBA代码循环遍历包含29个链接的行（B2：B30）（请参见图片），并将数据复制/粘贴到唯一的目标表中（在目标工作表的预定义行号（在第三列中指定：D2：D30）的第二列C2：C30）。

这是我要使用的代码：

Sub Import_Baskets()

Dim Rows As Long, links As Variant, link As Variant
Rows = Sheets("Admin").Cells(Sheets("Admin").Rows.Count, "B").End(xlUp).Row
links = Sheets("Admin").Range("B1:B" & Rows)

    For Each link In links

        Dim wkbMyWorkbook As Workbook
        Dim wkbWebWorkbook As Workbook
        Dim wksWebWorkSheet As Worksheet

        Set wkbMyWorkbook = ActiveWorkbook

        ' *************************************************
        ' Open The Web Workbook
        ' *************************************************

        ' *************************************************
        ' Set the Web Workbook and Worksheet Variables
        ' *************************************************
        Set wkbWebWorkbook = ActiveWorkbook
        Set wksWebWorkSheet = ActiveSheet

        ' *************************************************
        ' Copy The Web Worksheet To My Workbook and Rename
        ' *************************************************
        wksWebWorkSheet.Copy After:=wkbMyWorkbook.Sheets(Sheets.Count)
        wkbMyWorkbook.Sheets(ActiveSheet.Name).Name = "GC"

        '.Range("$A$" + row_number)
        ' *************************************************
        ' Close the Web Workbook
        ' *************************************************
        wkbMyWorkbook.Activate
        wkbWebWorkbook.Close


    Next link

    'Next


End Sub

任何帮助将不胜感激！：）

Answer 1

这可能适合您的情况。虽然尚未进行测试，所以请在尝试之前保存您的工作簿。

Sub Import_Baskets()

    Dim lastRow As Long, link As String
    Dim targetSheet As Worksheet
    Dim webBook As Workbook
    Dim webSheet As Worksheet
    Dim shName As String
    Dim stRow As Long

    With ThisWorkbook.Worksheets("Admin")

        lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row

        ' set your start and last row
        For row = 2 To lastRow

            link = Trim(CStr(.Range("B" & row).Value))
            shName = Trim(CStr(.Range("C" & row).Value))
            stRow = .Range("D" & row).Value

            ' open web wb
            Set webBook = Workbooks.Open(link)

            ' set web ws
            Set webSheet = webBook.Worksheets("enter desired sheet name")

            ' copy & paste
            On Error GoTo CreateSheet
            Set targetSheet = ThisWorkbook.Worksheets(shName)
            On Error GoTo 0
            webSheet.UsedRange.Copy destination:=targetSheet.Range("A" & stRow)

            ' close web wb        
            webBook.Close
            .Activate
        Next
    End With
    Exit Sub

' if sheet doesn't exist, insert it
CreateSheet:
    With ThisWorkbook
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = shName 
    End With
    Resume Next

End Sub

Excel / VBA-遍历URL列表（29个.xls文件）以打开数据并将其粘贴到一张纸中

1 个答案: