Уважаемые спецы,

Возникла проблема и без вашей квалифицированной помощи не справиться.
Итак:
Есть файл - CreateFille. В нем содержаться все необходимые данные и параметры на двух страницах.
Есть файл - Проформа графика. Это шаблон графика - пустышка.

Что надо в итоге получить:
Некоторое количество файлов с уникальными данными и названиями. Все названия файлов находится в файле CreateFille на листе "Итог".
в колонке Наименование зоны.
Все остальные параметры нужно скопировать из CreateFille листа "Итог" и листа "Динамика чеков" в файл "Проформа файла" в два листа. Как мне представлялся алгоритм:

В файле CreateFille листа "Итог" взять первую зону в столбце В - "График_Аксесуари для ванних кімнат.xls"

1. Взять данные из CreateFille и подставить данные в файл Проформа графика:
CreateFille лист "Итог" ячейка I5 в "Проформа файла" лист "Параметры" ячейку B2
CreateFille лист "Итог" ячейка J5 в "Проформа файла" лист "Параметры" ячейку B3
CreateFille лист "Итог" ячейка K5 в "Проформа файла" лист "Параметры" ячейку B4
CreateFille лист "Итог" ячейка L5 в "Проформа файла" лист "Параметры" ячейку B7
CreateFille лист "Итог" ячейка C5 в "Проформа файла" лист "Параметры" ячейку B14
CreateFille лист "Итог" ячейка D5 в "Проформа файла" лист "Параметры" ячейку B15
CreateFille лист "Итог" ячейка E5 в "Проформа файла" лист "Параметры" ячейку B20
CreateFille лист "Итог" ячейка F5 в "Проформа файла" лист "Параметры" ячейку B23

2. Взять данные из CreateFille и подставить данные в файл Проформа графика:
CreateFille лист "Итог" ячейка G5 в "Проформа файла" лист "Потребность в кадровых ресурсах" ячейку А3

3. В CreateFille листе "Динамика чеков" найти зону "График_Аксесуари для ванних кімнат.xls" и скопировать диапазон С4:F17 в файл "Проформа файла" лист "Динамика распределения продаж" в диапазоне B23:E36

4. Файл сохранить как "График_Аксесуари для ванних кімнат.xls" - по названию зоны.

5. Найти следующую зону в файле CreateFille листа "Итог" столбце В.

Набросал алгоритм, но он кривой у меня и тормозить сильно.
Файлы прилагаются.
Кто сможет помочь мне?

Вдогонку второй файл. Два файла не влезли в первый топик.

Sub CreateFile()

Dim i As Integer
Dim j As Integer

Dim nFiles As Integer '
Dim hRange As Integer
Dim startRows As Integer

Dim strPath As String
Dim strFile As String
Dim FPath As String



Call Prepare


'--------------------------------------------------------

startRows = 4 '
hRange = 14

With Workbooks("CreateFille").Worksheets(2)


strPath = .Range("C1")
strFile = .Range("C2")

FPath = .Range("C3")
.Activate
End With

'-----------------------------------------------------------------------------------
strB = strPath & "\" & strFile
nFiles = Workbooks("CreateFille").Worksheets(2).Range("B5").CurrentRegion.Rows.Count 'Ïîäñ÷åò êîëè÷åñòâà ôàéëîâ
'Range("A1").CurrentRegion.Select

Set Rng = Workbooks("CreateFille").Worksheets(2).Range(Cells(5, 2), Cells(nFiles, 12)) '

hRangeSeach = Workbooks("CreateFille").Worksheets(1).Range("B4").CurrentRegion.Rows.Count


Workbooks("CreateFille").Worksheets(1).Activate
Set RngSeach = Workbooks("CreateFille").Worksheets(1).Range(Cells(startRows, 1), Cells(hRangeSeach, 6))

For i = 1 To nFiles - 4 '
'Debug.Print i, dFiles

Filename = CStr(Rng(i, 1)) '
Set foundCell = RngSeach.Cells.Find(What:=Filename, LookIn:=xlValues, LookAt:=xlPart)

If Not foundCell Is Nothing Then
rowaddress = foundCell.Row
'Debug.Print rowaddress


Set MidRange = RngSeach.Range(Cells(rowaddress - 3, 3), Cells(rowaddress + hRange - 4, 6))
çåé

Set xlBook = Workbooks.Open(Filename:=strB, ReadOnly:=False, UpdateLinks:=False)
ActiveWorkbook.CheckCompatibility = False




xlBook.Worksheets(1).Range("B23:E36").Value = MidRange.Value '

With xlBook.Worksheets(2)
.Range("B2").Value = Rng(i, 8).Value '
.Range("B3").Value = Rng(i, 9).Value '
.Range("B4").Value = Rng(i, 10).Value '
.Range("B7").Value = Rng(i, 11).Value '
.Range("B14").Value = Rng(i, 2).Value '
.Range("B15").Value = Rng(i, 3).Value '
.Range("B20").Value = Rng(i, 4).Value '
.Range("B23").Value = Rng(i, 5).Value '

End With
Worksheets(3).Range("A3").Value = Rng(i, 6).Value '


xlBook.SaveAs Filename:=FPath & "\" & Filename

Call Ended
xlBook.Close SaveChanges:=True

'xlBook.Worksheets(2).Range("B2").Value = Rng(i, 8).Value

startRows = startRows + hRange
Else
MsgBox "Íåò äàííûõ äëÿ çîíû: " & Filename & "."
End If


Next i

'If DelStrok Then ' i?iaa?ea aoaai ee oaaeyou ionoua no?iee
' Call DelStrokRange 'iiaee??aiea ooieoee ii oaaeaie? ionouo no?ie
'End If


Call Ended
ActiveWorkbook.CheckCompatibility = True

End Sub




Public Sub Prepare()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False
End Sub

Public Sub Ended()
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
Application.DisplayStatusBar = True
Application.DisplayAlerts = True
End Sub