Loop cell in range, each cell in range copy and paste to multiple Workbooks

Question

there is a task in VBA Excel.

In Excel file “List”, loop through cells in range. Range ("B2: B4”).
Copy cell B2 in the file “List” and paste into cell A2 in Excel-file “1”.
Copy cell B3 in the file “List” and paste into cell A2 in Excel-file “2”.
Copy cell B4 in the file “List” and paste into cell A2 in Excel-file “3”. All this will do using loops. The problem is that the loops cells in range in file “List” copy work together loop workbooks in directory path (Excel files 1, 2, 3) for paste.

The range actually contains almost 1,600 cell. But I reduced it to understand the problem.

Please help solve the problem.

Sample files are attached. There is a code (below), but it does not work.

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

Super Symmetry Super Symmetry · Accepted Answer · 2020-07-05T11:01:54

Try this

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

Please note the assumptions

Loop cell in range, each cell in range copy and paste to multiple Workbooks

1 Answers