Макросы. Массовый перенос данных.

Макрос для переноса данных.

Вот так выглядит Меню выбора для переноса.

В столбец "Лист" - вносим наименование Листа (приемника), в столбец "Ячейка" - наименование ячейки в которую необходимо внести данные, а в столбец "Данные" соответственно данные которые необходимо разнести в выбранные файлы. (кол-во данных не ограничено, так же, как и файлов). Скачать файл можно после перевода на содержание и развитие сайта.

Для остальных, начнем свое повествование. Создадим Модуль (кто не знает - обращаемся к Введению) и вставим макрос..

Sub gerData()
Dim fName
Dim srcBook
Dim dstBook
Dim configBook
Dim rwIndex
Dim colIndex
Dim CloseSrc
Application.ScreenUpdating = False

Set configBook = ThisWorkbook
thisFName = ThisWorkbook.FullName
fName = Application.GetOpenFilename(fileFilter:="Выберите файлы.*, *.*", MultiSelect:=True)
 If IsArray(fName) Then
  Dim i
   For i = 1 To UBound(fName)
    If thisFName <> fName(i) Then
     ' Открываем
      CloseSrc = False
       For j = 1 To Workbooks.Count
        If Workbooks(j).FullName = fName(i) Then Set srcBook = Workbooks(j)
       Next j
        If Not IsObject(srcBook) Then
         'Отключаем запрос на подтверждение
          Application.DisplayAlerts = False
          Set srcBook = Workbooks.Open(Filename:=fName(i), ReadOnly:=False, UpdateLinks:=0)
          CloseSrc = True
        End If
      ' Читаем
       Dim k
       Dim d
       Dim Code
       Dim srcSheet
       Dim srcRange
       Dim srcValue
       Dim rangeFound
         k = 5
         While Not IsEmpty(configBook.Worksheets(1).Cells(k - 1, 1))
          srcSheet = configBook.Worksheets(1).Cells(k - 1, 1).Value
          srcRange = configBook.Worksheets(1).Cells(k - 1, 2).Value
          srcValue = configBook.Worksheets(1).Cells(k - 1, 4).Value
          rangeFound = False
          Dim l
           For l = 1 To srcBook.Sheets.Count
            If srcBook.Sheets(l).Name = srcSheet Then
              srcBook.Sheets(srcSheet).Range(srcRange).Value = srcValue
              rangeFound = True
              Exit For
            End If
           Next l
          If Not rangeFound Then
          MsgBox srcBook.FullName & " " & configBook.Worksheets(1).Cells(k, 1).Value & " not found"
          End If
         k = k + 1
          Wend
           ' Закрываем, если надо....
           If CloseSrc Then srcBook.Close SaveChanges:=True
            Set srcBook = Nothing
            srcBook = ""
  End If
 Next i
 MsgBox "Готово! "
End If
End Sub

Вот вообщем-то и все...