循环范围内的单元格，范围中的每个单元格复制并粘贴到多个工作簿

Question

VBA Excel中有一个任务。

1. 在Excel文件"列表"中，循环访问范围内的单元格。范围("B2：B4"(。
2. 复制文件"列表"中的单元格B2，然后粘贴到Excel文件" 2"中的单元格A1中。
3. 复制文件"列表"中的单元格B3，然后粘贴到Excel文件" 2"中的单元格A2中。
4. 复制文件"列表"中的单元格B4，然后粘贴到Excel文件" 2"中的单元格A3中。 所有这些都将使用循环来完成。 问题是文件"列表"副本中范围内的循环单元格协同工作循环目录路径(Excel文件1,2,3(中的工作簿以进行粘贴。

该系列实际上包含近 1,600 个单元格。但我缩小了它以了解问题所在。

请帮助解决问题。

示例文件已附加。有一个代码(如下(，但它不起作用。

Sub KopirovanieIVstavkaVRaznyeWorkbook()
Dim MyRange As Range
Dim MyCell As Range
Dim MyFiles As String
Set MyRange = Application.Workbooks(List.xlsm).Worksheets("Sheet1").Range("B2:B4")

For Each MyCell In MyRange
If MyCell > 0 Then
MyFiles = Dir("C:UsersUserDesktopPapka*.xlsx")
Do While MyFiles <> “”

Workbooks.Open "C:UsersUserDesktopPapka" & MyFiles
ActiveWorkbook.Worksheets(1).Range("A2") = MyCell
ActiveWorkbook.Close SaveChanges:=True
MyFiles = Dir

Exit Do
Loop

Else
MyCell.Offset(0, 1).Value = "Pusto"

End If
Next MyCell
End Sub

Answer 1

试试这个

Sub KopirovanieIVstavkaVRaznyeWorkbook()
Dim MyRange As Range
Dim MyFile As String
Dim i As Long
Dim wb As Workbook

Set MyRange = ThisWorkbook.Sheets("Sheet1").Range("B2:B4")
With MyRange
For i = 1 To .Rows.Count
' Assumes Excel files are named "Excel-file n.xlsx", where n is an integer
MyFile = "C:UsersUserDesktopPapkaExcel-file " & i & ".xlsx"

Set wb = Workbooks.Open(MyFile)
' Assume the target A1 is in the first sheet of the workbook
wb.Sheets(1).Range("A1").Value = .Cells(i, 1).Value
wb.Close SaveChanges:=True
.Cells(i, 1) = "Pusto"
Next i
End With
End Sub

请注意假设