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

【问题标题】：Loop cell in range, each cell in range copy and paste to multiple Workbooks循环范围内的单元格，范围内的每个单元格复制并粘贴到多个工作簿
【发布时间】：2020-07-05 07:22:51
【问题描述】：

VBA Excel 中有一个任务。

在 Excel 文件“列表”中，循环遍历范围内的单元格。范围（“B2：B4”）。
复制“列表”文件中的单元格 B2 并粘贴到 Excel 文件“1”中的单元格 A2 中。
复制“列表”文件中的单元格 B3 并粘贴到 Excel 文件“2”中的单元格 A2 中。
复制文件“列表”中的单元格 B4 并粘贴到 Excel 文件“3”中的单元格 A2 中。所有这些都将使用循环来完成。问题是文件“列表”副本中的循环单元格在目录路径（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:\Users\User\Desktop\Papka\*.xlsx")
            Do While MyFiles <> “”
    
        Workbooks.Open "C:\Users\User\Desktop\Papka\" & 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

【问题讨论】：

标签： excel vba loops foreach

【解决方案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:\Users\User\Desktop\Papka\Excel-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

请注意假设

【讨论】：