ХЭЛП, дублирование листа с разным заголовком из столбца

[Костя Мещериков]

Все доброго дня! мучаюсь второй день.
есть лист с таблицей, который нужно клонировать/копировать и в заголовок каждого листа нужно вставить данные из столбца этой же книги или другой не так уж важно. Вставка по порядку: лист1 - заголовок ячейка Ай, Лист2 - ячейка - а2 и так далее до n

Пример 1: копировать лист "kletki", в заголовок каждого листа вставить данные с "Sheet1"

[vikttur]

Без Вашего файла-примера и показанных попыток так и будете мучиться дальше...

[Костя Мещериков]

добавил файл!

[vikttur]

Сначала удаляются все листы, кроме двух исходных, потом создаются новые по количеству имен в таблице.
Лист с шахматкой скрыт. Если нужно, отобразите, на работе макроса не скажется.
Проверку на дубли не делал. Если в таблице встретятся одинаковые имена - ошибка при  создании листа.

[boa]

Добавил обработку дублей:

Код Выделить Развернуть


Option Explicit

Sub NewSheets()
Dim sht As Worksheet
Dim lRw As Long
Dim COL As New Collection
Dim a As Variant
    With wsName
        lRw = .Cells(.Rows.Count, "A").End(xlUp).Row
        If lRw < 2 Then Exit Sub
        On Error Resume Next 'что бы не "вылетать" на дубликатах при создании коллекции
        For Each a In .Range("A2:A" & lRw).Value: COL.Add CStr(a), CStr(a): Next a
        On Error GoTo 0 'что бы увидеть последующие ошибки
    End With
   
    With Application: .ScreenUpdating = False: .DisplayAlerts = False: End With
   
    ' в цикле удаляем все листы, кроме двух
    For Each sht In Worksheets
        If Not (sht.Name = ws0.Name Or sht.Name = wsName.Name) Then sht.Delete
    Next sht
   
    For Each a In COL
        ws0.Copy Before:=Sheets(1)      ' копируем лист
        With Sheets(1)
            .Visible = xlSheetVisible   ' отображаем новый лист
            .Name = a                   ' имя нового листа
            .Range("C2").Value = a      ' имя в ячейку
        End With
    Next a
   
    With Application: .ScreenUpdating = True: .DisplayAlerts = True: End With
End Sub


[Костя Мещериков]

Спасибо огромное.
Скажите еще как увеличить количество знаков в строке, которая вставляется в шапку,  не дает больше 32...

[vikttur]

Странно... 255 должно разрешать без проблем. да и больше можно...

[Костя Мещериков]

Подозреваю это связано с тем, что лист обзывается именем ячейки, подскажите как убрать это, пусть именуются Лис 1, Лист 2 и т.д., или sheet1....
Да, точно ругается на длину имени листа больше 32 символов.
Имена листов вообще не важны, важно чтобы могла вставляться большая подпись из колонок ..
Помогите !

[boa]

Переменная i как счетчик, а название "Лист" можете поменять

Код Выделить Развернуть

Option Explicit

Sub NewSheets()
Dim sht As Worksheet
Dim lRw As Long
Dim COL As New Collection
Dim a As Variant
    With wsName
        lRw = .Cells(.Rows.Count, "A").End(xlUp).Row
        If lRw < 2 Then Exit Sub
        On Error Resume Next 'что бы не "вылетать" на дубликатах при создании коллекции
        For Each a In .Range("A2:A" & lRw).Value: COL.Add CStr(a), CStr(a): Next a
        On Error GoTo 0 'что бы увидеть последующие ошибки
    End With
   
    With Application: .ScreenUpdating = False: .DisplayAlerts = False: End With
   
    ' в цикле удаляем все листы, кроме двух
    For Each sht In Worksheets
        If Not (sht.Name = ws0.Name Or sht.Name = wsName.Name) Then sht.Delete
    Next sht
   
    Dim i As Long
    For Each a In COL
        i = i + 1
        ws0.Copy Before:=Sheets(1)      ' копируем лист
        With Sheets(1)
            .Visible = xlSheetVisible   ' отображаем новый лист
            .Name = "Лист" & i 'a       ' имя нового листа. кроме "Sheet"
            .Range("C2").Value = a      ' имя в ячейку
        End With
    Next a
   
    With Application: .ScreenUpdating = True: .DisplayAlerts = True: End With
End Sub

[Костя Мещериков]

Спасибо огромное ГУРУ!
Все заработало!