Страницы: 1
RSS
Автоматическое добавление столбцов с данными в Лист1 при добавлении новых листов с данными
 
Доброго времени суток, товарищи!

Помогите, пожалуйста, с задачей:
Есть стандартный шаблон анкет, которые заполняются с определенной периодичностью. Нужно проводить анализ этих анкет, так как интересуют не все её вопросы. Для этого я создал отдельный лист "Анализ", куда вывел необходимые для этого отчета вопросы. После, посредством ссылок на ячейки и ВПР я проставляю "шапку" и баллы по каждому вопросу, ссылаясь на лист с анкетой за определённое число. Предварительно в анкете я добавляю столбец и через ПРАВСИМВ отделяю значение балла от "Шкала+Балл".
Для первого листа всё считает, вопросов нет. Вопрос в том, что таких листов с анкетами много и хотелось бы сделать так, чтобы при добавлении нового листа с анкетой (или нескольких листов с анкетами), автоматически добавлялся новый столбец и вытаскивал с неё (них) данные, как прописано в первом столбце.
Думаю, без макроса тут не обойтись, но может и через формулу можно реализовать как-то.
Скрытый текст

Пример во вложении.

Буду благодарен за любые варианты.
Нет ничего сложнее поиска простого решения.
 
Jykermann,
Код
Sub Добавить_анкеты()
Dim lcol As Long, sh As Worksheet, cell As Range, i As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
For Each sh In Worksheets
If sh.Name <> "Анализ" Then

lcol = Cells(2, Columns.Count).End(xlToLeft).Column + 1
Columns(lcol).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns(lcol - 1).Copy
Columns(lcol).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
    For i = 7 To lr
        Set cell = sh.Columns(1).Find(Cells(i, 1))
            If Not cell Is Nothing Then
                Cells(i, lcol) = cell.Offset(0, 4)
            End If
    Next i
        Cells(2, lcol) = sh.Name
        Cells(3, lcol) = sh.Cells(11, 2)
        Cells(4, lcol) = sh.Cells(13, 2)
        Cells(5, 3).Copy Destination:=Cells(5, lcol)
        Cells(13, 3).Copy Destination:=Cells(13, lcol)
        Cells(22, 3).Copy Destination:=Cells(22, lcol)
        Cells(25, 3).Copy Destination:=Cells(25, lcol)
        Cells(28, 3).Copy Destination:=Cells(28, lcol)
        Cells(34, 3).Copy Destination:=Cells(34, lcol)
        Cells(35, 3).Copy Destination:=Cells(35, lcol)
        Cells(40, 3).Copy Destination:=Cells(40, lcol)
        Cells(42, 3).Copy Destination:=Cells(42, lcol)
End If

Next sh
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub
Не бойтесь совершенства. Вам его не достичь.
 
Цитата
Jykermann написал:
Буду благодарен за любые варианты
Вариант: посмотреть на клиентов (клиентов=живых людей) не как на таблицу Excel :). Если это освоите, то и с макросами и с формулами разберетесь :)
 
Mershik,спасибо. Работает, но добавляет постоянно столбцы с данными со всех листов со 2 по последний, а не только "недостающий". Можно ли сделать, чтобы добавлялись только недостающие листы?
Нет ничего сложнее поиска простого решения.
 
_Igor_61, так это и делается для "живых людей" :)
Данную анкету заполняет тайный покупатель для того, чтобы можно было понять на сколько качественно персонал отрабатывает клиентов. Самих клиентов никто не тревожит с такой кучей вопросов, тем более с учетом того, что контингент клиентов - очень состоятельные люди :)
Нет ничего сложнее поиска простого решения.
Страницы: 1
Наверх