Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Копирование листа (образца) и присвоение ему имени из диапазона ячеек VBA
 
#1
21.02.2013 13:08:39
Уважаемые форумчане, подскажите пожалуйста в решении такой задачи.

Есть список названий листов в некотором диапазоне ячеек на одном из листов (примерно 200 листов, вручную копировать муторно) о_О.
1) Как размножить лист (образец) с присвоением ему имени из диапазона ячеек с данными.
2) Если лист с таким названием есть, то пропуск копирования.

Нашел подобную тему, но затрудняюсь в некоторых моментах
нужен цикл перебора диапазона ячеек для создания листов
при копировании листа назначать имя из ячейки диапазона имен

Код
Sub qwe()
Dim wsSh As Worksheet
   On Error Resume Next

   For Each wsSh In ThisWorkbook.Sheets
      If wsSh.Name = Sheets("Лист" ;) .[A1] Then
         Msgbox "Есть уже такой"
         Exit Sub
      End if
   Next

   Set wsSh = Sheets("Лист" ;) .[A1]
   Sheets("Лист" ;) .Copy After:=Sheets(Sheets.Count)
   Sheets("Лист (2)" ;) .Name = Sheets("Лист" ;) .[A1]
End Sub
 
 
 
#2
21.02.2013 14:50:41
На коленке делал, но вроде работает
Код
Sub CopySheetExample()
    Dim objListCopy As Worksheet
    Dim strLastName As String
    Dim rngName As Range 'диапазон нужных листов
    Dim rgCell As Range ' переменная для перебора коллекции
    
    strLastName = "Образец"
    
    Set rngName = ActiveWorkbook.Sheets("настр").Range("Нужные_листы")
    
    For Each rgCell In rngName
        If ExistList(rgCell.Value) = False Then
            ActiveWorkbook.Sheets("Образец").Copy ActiveWorkbook.Sheets(strLastName)
            Set objListCopy = ActiveWorkbook.Sheets(1)
            objListCopy.Name = rgCell.Value
            strLastName = rgCell.Value
        End If
        
        
    
    Next rgCell

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
 
 
 
#3
21.02.2013 14:55:08
Sergey_85
А что вот это: If wsSh.Name = Sheets("Лист";).[A1]; Then
Согласие есть продукт при полном непротивлении сторон
 
 
 
#4
21.02.2013 14:56:02
Смайлики сами ставятся. .[A1] ?
Согласие есть продукт при полном непротивлении сторон
 
 
 
#5
21.02.2013 14:56:43
Для ссылки на диапазон в котором находятся имена листов создал в книге имя "Нужные_листы". Его уже программно превратил в диапазон Range. Единственный вопрос. Не получилось получить сразу ссылку на скопированный лист. Может кто подскажет как. Конструкция вроде
Код
Set x = ActiveWorkbook.Sheets("Образец").Copy ActiveWorkbook.Sheets(strLastName)

Отказалась работать. Ругается -  "нужен объект"
 
 
 
#6
21.02.2013 14:56:44
Это скобки что-ли?
Согласие есть продукт при полном непротивлении сторон
 
 
 
#7
21.02.2013 15:03:33
Вот есть наброски, но нужно дорабатывать.
 
 
 
#8
21.02.2013 15:37:50
Всем огромное спасибо за участие!
Алексей Семенюк
единственное, что копируется еще и образец, но это не проблема удалить
а как ввести проверку на существование листа перед копированием или можно просто пропуск ошибки??
 
 
 
#9
21.02.2013 15:58:18
За проверку наличия листа отвечает функция ExistList(). В каком месте кода ее применить - дело хозяйкое. Функция работает исходя из следующих принципов:
1. Если есть лист с именем переданным в парамере strListName, возвращается значение "Верно"
2. Если такого листа нет - VBA генерирует ошибку, при возникновении которой выполнение идет от метки Metka и функция возвращает "Ложь" Т.е. листа нет.
Был у меня другой вариант проверки листа без вызывания ошибок по памяти не вспомню. Вечером выложу.
 
 
 
#10
21.02.2013 16:43:21
Цитата
Sergey_85 пишет:
а как ввести проверку на существование листа перед копированием
Посмотрите здесь и здесь
 
 
 
#11
21.02.2013 22:54:19
Поиск существующего листа без генерации ошибки.
Код
Function ExistSheet(strSheetName As String) As Boolean
    Dim shWsheet As Worksheet
    
       
    For Each shWsheet In ActiveWorkbook.Worksheets
    
        If shWsheet.Name = strSheetName Then
            ExistSheet = True 'òàêîé ëèñò óæå ñóùåñòâóåò
            Exit Function
        End If
        
    Next
    ExistSheet = False
End Function
 
 
 
Страницы: 1
Читают тему
Наверх