Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel (архив)
Страницы: 1
RSS
Макрос копирования именованных диапазонов и формул!
 
#1
31.08.2010 14:47:34
Может уже было, но поиском не нашёл. Пытаюсь написать макрос копирования всех именованных диапазонов и именованных формул из открываемого файла в текущий (открытый).  
Но что-то моих знаний не хватает.  
Привожу текст макроса и файл с ним во вложении.  
 
Sub CopyName()  
       Application.ScreenUpdating = False  
       Application.EnableEvents = False  
   Set ThisBook = ActiveSheet  
       filetoopen = Application.GetOpenFilename("Файлы Microsoft Office Excel, *.xls")  
   If filetoopen = False Then  
       End  
   End If  
   Set OpenFile = Workbooks.Open(filetoopen)  
       ThisBook.Unprotect Password:="123"  
       ThisBook.Activate  
 
   Dim iName As Name  
       For Each iName In OpenFile.Names  
           ThisBook.Names.Add iName.Name, iName.RefersTo  
   Next iName  
 
   ThisBook.Protect Password:="123", DrawingObjects:=True, Contents:=True, Scenarios:=True _  
   , AllowFormattingCells:=True, AllowFormattingColumns:=True, _  
   AllowFormattingRows:=True  
   OpenFile.Close SaveChanges:=False  
       Application.ScreenUpdating = True  
       Application.EnableEvents = True  
End Sub
 
 
 
#2
31.08.2010 15:10:44
Добавьте копирование диапазона в цикл по именам:  
 
   Dim iName As Name  
       For Each iName In OpenFile.Names  
           thisbook.Names.Add iName.Name, iName.RefersTo  
           On Error Resume Next  
           iName.RefersToRange.Copy thisbook.Range(iName)  
           On Error GoTo 0  
   Next iName  
 
Подавление ошибок нужно на случай, если имя не ссылается на диапазон, а содержит формулу.
 
 
 
#3
28.01.2011 22:12:18
Ребята, помогите пожалуйста исправить код.  
В вышеизложенном примере копируются все именованные диапазоны, а мне необходимо, чтобы копировался один, строго определенный именованный диапазон "Продажа_ZP".  
 
Ниже привожу код, однако не получается самостоятельно его исправить.  
Прошу помощи !?  
 
Sub Копирование_диапазона_из_друг_книги () '  
Dim TempWb As Workbook  
Dim BazaSht As Worksheet  
Dim wb As Workbook  
Dim wbBook As Boolean  
 
wbBook = False  
For Each wb In Workbooks  
If wb.Name = "ПРОДАЖИ_2011.xlsm" Then  
wbBook = True  
Exit For  
End If  
Next wb  
 
Dim iPath As String  
With Worksheets("Продажа ZP")  
.Activate  
End With  
With Application  
.ScreenUpdating = False  
.Calculation = xlCalculationManual  
Set BazaSht = Sheets("Продажа ZP")  
 
iPath = ActiveWorkbook.Path & "\"  
If Not wbBook Then  
Set TempWb = Workbooks.Open(Filename:=iPath & "ПРОДАЖИ_2011.xlsm", UpdateLinks:=False, ReadOnly:=True)  
Else  
Set TempWb = Workbooks("ПРОДАЖИ_2011.xlsm")  
End If  
 
TempWb.Sheets("Продажа ZP").Range("Продажа_ZP").Copy Destination:=BazaSht.Range("A3")  
 
If Not wbBook Then TempWb.Close saveChanges:=False  
.Calculation = xlAutomatic  
.ScreenUpdating = True  
End With  
 
End Sub
 
 
 
#4
28.01.2011 22:23:42
Забыл указать,  
 
скопированный именованный диапазон должен вставляться КАК ИМЕНОВАННЫЙ диапазон, а не просто как диапазон данных !!!
 
 
 
#5
28.01.2011 23:19:27
То есть вставленному диапазону надо присвоить имя. Замените  
 
TempWb.Sheets("Продажа ZP").Range("Продажа_ZP").Copy Destination:=BazaSht.Range("A3")  
 
на  
 
With TempWb.Sheets("Продажа ZP").Range("Продажа_ZP")  
   .Copy Destination:=BazaSht.Range("A3")  
   BazaSht.Range("A3").Resize(.Rows.Count, .Columns.Count).Name = "Продажа_ZP"  
End With
 
 
 
#6
29.01.2011 09:37:02
{quote}{login=Казанский}{date=28.01.2011 11:19}{thema=}{post}То есть вставленному диапазону надо присвоить имя. Замените  
 
TempWb.Sheets("Продажа ZP").Range("Продажа_ZP").Copy Destination:=BazaSht.Range("A3")  
 
на  
 
With TempWb.Sheets("Продажа ZP").Range("Продажа_ZP")  
   .Copy Destination:=BazaSht.Range("A3")  
   BazaSht.Range("A3").Resize(.Rows.Count, .Columns.Count).Name = "Продажа_ZP"  
End With{/post}{/quote}  
 
 
 
Господин Казанский, в очередной раз благодарю Вас за помощь !!!!
 
 
 
#7
06.06.2011 12:53:03
Подскажите в продолжение начала этой темы. Пользовался долго этим макросом и полностью устраивал, но тут копировал диапазоны и макрос выдал ошибку, стал разбираться - выяснил, что макрос спотыкается на именованной формуле в которой находится формула массива. В связи с этим два вопроса:  
1. Как изменить макрос, чтобы он копировал в том числе и именованные формулы массива?  
2. Как добавить по окончании информационное окно: В исходном файле найдено например 100 именованных диапазонов и формул. В текущий файл скопировано например 99.  
Файл прилагаю.
 
 
 
#8
06.06.2011 16:09:36
Макрос выдаёт ошибку на вот этот строке:  
thisbook.Names.Add iName.Name, iName.RefersTo  
Хотя после неё идёт код защиты от ошибок:  
On Error Resume Next  
Или я что не так понимаю?
 
 
 
#9
06.06.2011 16:36:45
Не вникая в подробности... "код защиты от ошибок" обычно ставят ДО того, как планируют ошибиться :-)
 
 
 
#10
06.06.2011 17:18:33
Спасибо огромное, теперь почему-то копирует все данные без проблем.
 
 
 
#11
06.09.2011 14:09:04
Доброго времени суток. Есть книга, допустим на 100 листов. В этой книге в каждом листе есть ячейка B2. Можно ли макросом, начиная с первого листа и до последнего, назначить этой ячейке имя вида Номер1, Номер2, Номер3 и т.д.?  
 
Был бы очень благодарен.
 
 
 
#12
06.09.2011 20:25:09
Sub DAntES()  
Dim intI As Integer  
Dim sh As Worksheet  
intI = 1  
For Each sh In Worksheets  
Names.Add Name:="Номер_" & intI, RefersTo:="=" & sh.Name & "!$B$2"  
intI = intI + 1  
Next  
End Sub
Кому решение нужно - тот пример и рисует.
 
 
 
Страницы: 1
Наверх