Страницы: 1
RSS
Копирование листа в новый файл, с присвоением ему имени и разрывом всех связей.
 
Добрый день, столкнулся с такой проблемой, есть объемный расчетный файл, все расчеты которого собираются в один лист "Итого", и я хотел написать макрос, для следующих действий с этим листом.

1) Копировать и переместить лист в новую книгу
2) Разорвать все связи
3) Сохранить этот лист в определенную папку, путь к которой известен
4) Наименование новой книги присвоить как в ячейке А1

Пытался сам собрать макрос, искал в интернете, так как сам пока такими знаниями не обладаю, но постоянно выдаёт ошибки. Так же пытался написать макрос посредством функции "Запись макроса", но в таком случае не получается добавить функции сохранить где надо, и назвать как надо.

Знаю что необходимо приложить пример, но не знаю как это сделать, так как, файл объемный.
 
Вот пока то, что получилось, не могу добавить сюда разрыв всех связей.
Код
Sub Макрос1()
Dim Директория As Variant
Dim Название_листа As Variant
Dim Текущая_дата As Date
Dim Номер_по_порядку As Variant

Application.ScreenUpdating = False
On Error Resume Next

Sheets("Итого").Select
Текущая_дата = Range("A1").Value
Номер_по_порядку = Range("A2").Value
Название_листа = ActiveSheet.Name

Sheets("Итого").Copy
ActiveWorkbook.SaveAs Filename:=Директория & Название_листа & "_" & Текущая_дата & "_№" & Номер_по_порядку & ".xls", FileFormat:=xlNormal
ActiveWindow.Close

Sheets("Упаковочный лист").Select
Номер_по_порядку = Номер_по_порядку + 1
Range("I2").Value = Номер_по_порядку
ActiveWorkbook.Save

Sheets("Печать").Select

Application.ScreenUpdating = True
End Sub
 
Пример по вашему заданию
Код
Sub test()
    Dim iPath$, iName$
    iPath = "Путь к папке" & Application.PathSeparator
    Worksheets("Итоги").Copy   '1) Копировать и переместить лист в новую книгу
    iName = Worksheets("Итоги").[a1].Value    '4) Наименование новой книги присвоить как в ячейке А1
    ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value     '2) Разорвать все связи
    ActiveWorkbook.SaveAs Falename:=iPath & iName & ".xlsx"    '3) Сохранить этот лист в определенную папку, путь к которой известен
End Sub
"Все гениальное просто, а все простое гениально!!!"
 
Nordheim,  Спасибо большое, но при попытке запуска макроса выдает ошибку "named argument not found" на данном этапе

Sub test()
 
Путь к папке указали?
Лист "итоги" существует?
"Все гениальное просто, а все простое гениально!!!"
 
Nordheim, Путь к папке для сохранения нового файла?
Да, указал
Код
Sub test()
    Dim iPath$, iName$
    iPath = "Y:\UBO\#1. ОРиТ\#РЕЗЕРВЫ\Для Данияра" & Application.PathSeparator
    Worksheets("Итоги").Copy   '1) Копировать и переместить лист в новую книгу
    iName = Worksheets("Итоги").[a1].Value    '4) Наименование новой книги присвоить как в ячейке А1
    ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value     '2) Разорвать все связи
    ActiveWorkbook.SaveAs Falename:=iPath & iName & ".xlsx"    '3) Сохранить этот лист в определенную папку, путь к которой известен
End Sub
 
Опечатка. Замените:
Цитата
Falename
на:
Цитата
Filename

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
JayBhagavan, Спасибо ! :)
Но теперь возникла новая ошибка,
Цитата
"Run-time error '1004': Method 'Save as' of object'_Workbook' failed
Код
ActiveWorkbook.SaveAs Filename:=iPath & iName & ".xlsx"   
 
Цитата
ksandaev написал: Run-time error '1004'
Погуглите ЭТО.

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
JayBhagavan, Nordheim, Еще раз Спасибо! Все заработало.

Есть еще вопрос, как я понял там идет не разрыв связи, а перевод в значения всего файла, а можно ли разорвать именно связи которые ссылаются на другие файлы, а формулы внутри листа оставить?
 
ksandaev, можно. Скопируйте вручную лист в новую книгу, включите макрорекордер, меню Данные/Изменить связи/Разорвать связь, выключить макрорекордер, зайти в редактор ВБА, открыть модуль с записанным макросом и адаптировать его под свои нужды.

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
Для разрыва связей текущей книги можно вызвать следующий макрос:
Код
Sub BreakLinks()
  Dim w1, w2, w3
  On Error Resume Next
  For Each w1 In Array(xlExcelLinks, xlOLELinks)
     w2 = ActiveWorkbook.LinkSources(w1)
     If w2 <> Empty Then
       For Each w3 In w2
         ActiveWorkbook.BreakLink w3, w1
       Next w3
     End If
  Next w1
  On Error GoTo 0
End Sub
Владимир
Страницы: 1
Наверх