Доброго дня гуру Экселя.... В очередной раз нужна Ваша помощь..
Макрос который копирует листы с именами из диапазона ячеек работает исправно.... С переборкой коллекции (пропуск если имена уже ессть)
За исключением того что если в ячейках в диапазоне с именами есть пустые уходит в ошибку..... Можете ли подредактировать так что бы он просто пропускал ошибку до завершения диапазона.....Не создавая листа...
И в определенную ячейку вставить имя листа
Будет вообще супер если получится лист образец спрятать и делать копии с него.. Если вариант сначала отобразить лист -- сделать копии----спрятать лист является оптимальным тогда так и сделаем....Мнение Гуру)
Все исправлено и работает как часы.....
Выкладываю результат коллективного труда
Спасибо всем кто откликнется.
Макрос который копирует листы с именами из диапазона ячеек работает исправно.... С переборкой коллекции (пропуск если имена уже ессть)
Все исправлено и работает как часы.....
Выкладываю результат коллективного труда
| Код |
|---|
Sub CopySheetExample()
Dim diapaz As Range 'диапазон нужных листов
'Dim i As Long
Dim list As Worksheet
Dim rgCell As Range ' переменная для перебора коллекции
On Error Resume Next
Set diapaz = ActiveWorkbook.Sheets("Договора").Range("A10:A20") ' Диапазон который для новых листов
'Set diapaz = Application.InputBox("Пожалуйста, выделите диапазон ячеек, который содержит названия для новых листов!", Type:=8)
On Error GoTo 0
If diapaz Is Nothing Then Exit Sub
Set list = Worksheets("0") 'ActiveSheet 'имя листа образца
'For i = 1 To diapaz.Count
'i = 1
For Each rgCell In diapaz 'диапазон нужных листов
list.Visible = xlSheetVisible 'отображает лист образец
If rgCell.Value <> "" Then
If ExistList(rgCell.Value) = False Then
list.Copy after:=Worksheets(Worksheets.Count) 'ActiveSheet
ActiveSheet.Name = rgCell.Value 'Left(diapaz(i), 31)
ActiveSheet.Range("A1") = rgCell 'Вставляет имя листа в ячейку А1
End If
End If
Next rgCell
list.Visible = xlSheetHidden 'Скрывает лист образец
End Sub
Function ExistList(strListName As String) As Boolean
Dim objWsheet As Worksheet
On Error GoTo Metka:
Set objWsheet = ActiveWorkbook.Sheets(strListName)
ExistList = True
Exit Function
Metka:
ExistList = False
End Function
|
Спасибо всем кто откликнется.
Изменено: - 09.12.2021 17:40:35
