Доброго времени суток.Помогите разобраться. Вроде не сложно, но чет не могу написать как полагается.
Книга 1(расчетный файл, здесь макрос), Лист4 в диапазоне А1:A21 название клиентов. Нужно взять название клиента из A1,зайти в заданную папку (нужно задать один раз для всего цикла) где лежит Книга2 у которой есть 20 вкладок, нужно найти вкладку с названием из ячейки А1. Скопировать данные с этой вкладки в Книгу1, Лист1. Второй шаг. Найти опять клиента по названию с ячейки А1 в заданной папке файл (задать путь 1 раз для всего цикла), открыть файл, скопировать вкладку (она там одна) и вставить данные в Книгу1 Лист2. Третий шаг. Перейти в расчетном файле (куда скопировали 2 вкладки) на Лист 3, пересчитать все формулы. Сохранить эту одну вкладку в заданной папке (также задать путь для всего цикла) с названием с ячейки А1, и переименовать вкладку на название с А1, обрезать связи, сохранить и перейти к 2 клиенту в ячейке А2 и так по всем клиентам. У нас есть 1 расчетный файл, путь 1 где лежит 1 файл у которого есть 20 вкладок (по одной вкладке на клиента), путь 2, где лежат 20 файлов с названиями клиентов (в каждом файле только 1 вкладка), путь 3 где нужно сохранить результат, только 1 вкладку с названием из ячейки. В конце в папке по пути 3 должно быть 20 файлов.
Внизу примерный макрос, Если можно его дописать, если это и вовсе не годится тогда наверное заново все.
| Код |
|---|
On Error Resume Next
Dim sFolder As String, sFiles As String
Dim MSdatafile
Data1Folder$ = GetFolder(1, , "Виберите папку с файлом") ' путь 1 папка гдележит 1 файл у которого 20 вкладок
If InvoiceFolder$ = "" Then MsgBox "Не выбрано", vbCritical, "Завершено": Exit Sub
Data2Folder$ = GetFolder(1, , "Виберите папку с файлами") ' путь 2
If InvoiceFolder$ = "" Then MsgBox "Не выбрано", vbCritical, "Завершено": Exit Sub
Data3Folder$ = GetFolder(2, , "Виберите папку куда сохранять файлы") ' путь 3
If ArchieveFolder$ = "" Then MsgBox "Папка не задана", vbCritical, "Завершено": Exit Sub
Set sht = book.Sheets(
Numrows = Range("E2", Range("E2").End(xlDown)).Rows.Count ' диапазон названия клиентов
For x = 1 To Numrows
With sht
arr = .Range(.Cells(2, 1), Cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count))
End With
'-----------------------ШАГ ОДИН-----------------------
'Data1Folder$ тут лежит 1 файл где есть 20 вкладок, найти владку с названием из ячейки A1
Workbooks("Книга2.xlsx").Worksheets("Клиент1").Range("A1:T200").Copy ' тут нужно сделать цикл а не жестко привязать название клиента
Windows("Книга1.xlsm").Activate ' книга в которую копируем, расчетный файл
Sheets("Лист1").Select ' вкладка куда копируем данные
Cells.Select ' диапазон куда копируем
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False ' вставляем только значения
ActiveSheet.Paste
Application.CutCopyMode = False ' отменить выделенный диапазон
'-----------------------ШАГ ДВА-----------------------
' выбрать папку Data2Folder$ тут лежит 20 файлов из названиями. Нужно найти файл с названием из ячейки А1
Set wb = Application.Workbooks.Open(sFolder & sFiles) 'здесь скорее всего неправильно
wb.Sheets(1).Range("A1:T200").Copy
Workbooks("Книга1.xlsm").Worksheets("Лист2").Range("A1").PasteSpecial Paste:=xlPasteValues ' куда копируем
Application.CutCopyMode = False ' отменить выделенный диапазон
wb.Close True 'закрыть файл откуда скопировали данные
sFiles = Dir
'-----------------------ШАГ ТРИ-------------------------------
Windows("Книга1.xlsm").Activate '
Sheets("Лист3").Select
Application.Calculate ' пересчитываем все формулы в Книге1
Data3Folder$ 'сюда сохраняем Лист3, с названием из ячейки А1, переименовываем Лист1 также на название с ячейки А1, обрываем связи
Workbooks("Книга1.xlsm").Worksheets("Лист3").SaveCopyAs Path & Имя_для_сохранения & ".xlsx" ' сохраняем
Конец цикла, переходим к ячейке А2, делаем все то же, до конца списка клиентов.
End Sub
|
