Профессиональные приемы работы в Microsoft Excel

Пожалуйста, войдите или зарегистрируйтесь.


Расширенный поиск  

Новости:

Из правил форума: Тема должна отражать суть вопроса, топики типа "help please" будут удаляться!

Автор Тема: ХЭЛП, дублирование листа с разным заголовком из столбца  (Прочитано 421 раз)

0 Пользователей и 1 Гость просматривают эту тему.

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

  • Новичок
  • *
  • Уважение: +0/-0
  • Оффлайн Оффлайн
  • Сообщений: 5

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

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

« Последнее редактирование: 18.01.2018, 18:12:59 от Костя Мещериков »
Записан

vikttur

  • Глобальный модератор
  • Старожил
  • *****
  • Уважение: +49/-0
  • Оффлайн Оффлайн
  • Сообщений: 990

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

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

  • Новичок
  • *
  • Уважение: +0/-0
  • Оффлайн Оффлайн
  • Сообщений: 5
Записан

vikttur

  • Глобальный модератор
  • Старожил
  • *****
  • Уважение: +49/-0
  • Оффлайн Оффлайн
  • Сообщений: 990

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

boa

  • Глобальный модератор
  • Старожил
  • *****
  • Уважение: +32/-0
  • Оффлайн Оффлайн
  • Сообщений: 540
  • Доброта спасет мир...

Добавил обработку дублей:
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
Записан
Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра

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

  • Новичок
  • *
  • Уважение: +0/-0
  • Оффлайн Оффлайн
  • Сообщений: 5

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

vikttur

  • Глобальный модератор
  • Старожил
  • *****
  • Уважение: +49/-0
  • Оффлайн Оффлайн
  • Сообщений: 990

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

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

  • Новичок
  • *
  • Уважение: +0/-0
  • Оффлайн Оффлайн
  • Сообщений: 5

Подозреваю это связано с тем, что лист обзывается именем ячейки, подскажите как убрать это, пусть именуются Лис 1, Лист 2 и т.д., или sheet1....
Да, точно ругается на длину имени листа больше 32 символов.
Имена листов вообще не важны, важно чтобы могла вставляться большая подпись из колонок ..
Помогите !
« Последнее редактирование: 19.01.2018, 19:47:05 от Костя Мещериков »
Записан

boa

  • Глобальный модератор
  • Старожил
  • *****
  • Уважение: +32/-0
  • Оффлайн Оффлайн
  • Сообщений: 540
  • Доброта спасет мир...

Переменная 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
Записан
Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра

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

  • Новичок
  • *
  • Уважение: +0/-0
  • Оффлайн Оффлайн
  • Сообщений: 5

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



Темы без ответов

30.09.2018 10:24 Расчет процентов за определенный период (месяц) с учетом изменений и платежей 380
22.05.2018 11:38 Скрипт написать который допишет данные в файл 1040
03.03.2018 00:00 Подсчет отработанного времени, за исключением заранее определенных перерывов 1176
14.02.2018 10:11 Подготовить читабельную отчетность по платежам 1168
23.01.2018 13:46 Найти вероятность повторной покупки 1061
12.01.2018 23:56 Сделать отчет на Power BI (Dashboard) 1496
06.09.2017 10:43 Solver VBA не решает гиперболическое уравнение, но при этом решает гармоническое 1357
17.08.2017 12:15 Гиперссылка и фильтр одновременно макрос 1703
23.05.2017 11:20 Копирование данных из одной таблицы в умную таблицу по условию 3440
15.03.2017 15:45 автозамена картинок PowerPoint 1954





Яндекс цитирования msexcel.ru Яндекс.Метрика

Страница сгенерирована за 0.226 секунд. Запросов: 102.