Новости:

Теперь на форум можно залогиниться / зарегистрироваться с помощью ВКонтакте. Уже существующие пользователи могут связать свою учетную запись с аккаунтом ВКонтакте одним кликом в профиле пользователя http://forum.msexcel.ru/index.php?action=profile;area=account

Главное меню

Быстрое создание сводной таблицы с помощью макроса !!

Автор Che79, 30.07.2011, 19:25

« назад - далее »

Che79

Всем здравствуйте!
Прошу помощи у профессионалов))
Суть вопроса. Есть книга с N-ым количеством листов (на листах таблицы по принципу "Цена-количество-стоимость") и одним сводным, где с помощью формул отображаются необходимые данные с каждого листа.
Подскажите, плиз, макрос(ы) для быстрого создания такой сводной!!
Количество листов с данными в книге может быть очень велико (по регионам, например) и каждый раз различно.
"Ручное" создание сводной хорошо, когда количество листов небольшое. Например, простым копированием и заменой в названии листа, поскольку все таблицы на листах строго совпадают по ячейкам. Но когда листов в книге 100 и более, то можно чокнуться :)

Пример прикрепил. Для понимания, это расчет рекламной кампании абстрактного клиента на ТВ.

Заранее всем спасибо

С уважением к форуму,
Делай нормально и будет нормально!

GWolf

#1
Доброй ночи!

Смутило использование термина "Сводная таблица". В Excel этим термином обозначен вполне конкретный инструментарий. А Вам, я так понял, требуется:
  - опросить ВСЕ листы книги и собрать информацию с опрашиваемых листов в Отчет определенного вида.
И Инструментарий Сводных таблиц Вам для этого не (совсем) подходит?!

Что ж, начнем:

В модуле:

Sub opRosWS()
   Dim ws As Worksheet
   For Each ws In ThisWorkbook.Worksheets
       If ws.Name <> "Сводный" Then
           With ws
               .Activate
               .Cells(1, 1).Select
               MsgBox "Активен лист " & .Name, vbInformation + vbOKOnly, "Местоположение:"
           End With
       End If
   Next
   
   ThisWorkbook.Worksheets("Сводный").Activate
End Sub

Путей к вершине - множество. Этот один из многих!

Che79

GWolf, спасибо за помощь! Начинаю двигаться к цели!
А как бы сделать так, чтобы при добавлении в книгу большого кол-ва листов нужные данные из каждого листа добавлялись в сводник к том же формате, как в примере. Мне собственно это и нужно))
Делай нормально и будет нормально!

GWolf

#3
Доброй ночи!

Итак, продолжим. Для начала определим границы занятого информацией поля листа:

Sub opRosWS()
    Dim ws As Worksheet
    Dim iDiapazon As Range
    Dim nREnd As Long, nCEnd As Long, i As Long
    Dim stroka As String

   For Each ws In ThisWorkbook.Worksheets
       If ws.Name <> "Сводный" Then
           With ws
               .Activate
               .Cells(1, 1).Select
               '== Границы занятого информацией поля листа == Start ===
               Set iDiapazon = .UsedRange
               With iDiapazon
                   nREnd = .Row + .Rows.Count - 1
                   nCEnd = .Column + .Columns.Count - 1
               End With
               Set iDiapazon = Nothing
               '== Границы занятого информацией поля листа == Stop ====
               i = 0
               For i = nREnd To 1 Step -1
                   stroka = ""
                   stroka = .Cells(i, 1).Text
                   If InStr(1, stroka, "Регион", vbTextCompare) > 0 Then
                       MsgBox "Найден информационный блок по " & .Cells(i + 1, 1).Text, vbExclamation + vbOKOnly, "для " & stroka
                   End If
               Next i
               
               MsgBox "Активен лист " & .Name & Chr(10) & Chr(10) & _
                      "Справочно:" & Chr(10) & _
                      "Информация расположена в границах:" & Chr(10) & _
                      "     - строки: с 1-ой по " & CStr(nREnd) & "-ю;" & Chr(10) & _
                      "     - колонки: c 1-ой по " & CStr(nCEnd) & "-ю;", vbInformation + vbOKOnly, "Местоположение:"
           End With
       End If
   Next
   
   ThisWorkbook.Worksheets("Сводный").Activate
End Sub


т.о. установив границы информационного поля листа, далее, при помощи цикла For ... Next мы перемещаемся по этому полю, отыскивая идентификаторы информационных блоков. В этом, конкретном случае, таковыми будут "Регион".
  Подобным механизмом можно "вытащить" практически из любой информационной структуры (например - таблицы) любую информацию.
Путей к вершине - множество. Этот один из многих!

GWolf

Цитата: Che79 от 12.08.2011, 22:26
А как бы сделать так, чтобы при добавлении в книгу большого кол-ва листов нужные данные из каждого листа добавлялись в сводник к том же формате, как в примере. Мне собственно это и нужно))

Поясните, пожалуйста: Вам нужно готовое решение, или на основании моих комментариев Вы решение сделаете сами?
Путей к вершине - множество. Этот один из многих!

Che79

в идеале мне нужна некая схема (набор макросов), которую я адаптирую под свою задачу. Спасибо.
Делай нормально и будет нормально!

GWolf

Цитата: Che79 от 13.08.2011, 00:06
в идеале мне нужна некая схема (набор макросов), которую я адаптирую под свою задачу. Спасибо.

Ну, собственно, ничего не понял. С идеалом - понятно. А чем же я тут с Вами занимаюсь?
Путей к вершине - множество. Этот один из многих!

Che79

прошу прощения, совсем разучился мысли формулировать :)
В общем, есть изначально описанная задача. Как ее решить быстро, я не знаю, а вручную заниматься построением сводника данных, собирая их с помощью привязок со 100 и более листов - я с ума скоро сойду..
В любом случае, огромное спасибо за помощь!
Делай нормально и будет нормально!

GWolf

Цитата: Che79 от 13.08.2011, 00:23
прошу прощения, совсем разучился мысли формулировать :)
В общем, есть изначально описанная задача. Как ее решить быстро, я не знаю, а вручную заниматься построением сводника данных, собирая их с помощью привязок со 100 и более листов - я с ума скоро сойду..

Попробуем решить Вашу проблему. Тем более впереди два выходных.

А вот и дальнейшее развитие задачи. Пусть Вас не пугает то, что программа идет как бы снизу вверьх. По окончании сбора инфы отсортируем по Станция и все.

Итак:

Sub opRosWS()
    Dim ws As Worksheet
    Dim iDiapazon As Range
    Dim nREnd As Long, nCEnd As Long, i As Long, nRTo As Long
    Dim stroka As String
   
    nRTo = 10
    For Each ws In ThisWorkbook.Worksheets
        stroka = ""
        stroka = ws.Name
        If InStr(1, stroka, "Сводный", vbTextCompare) = 0 Then
            With ws
                .Activate
                .Cells(1, 1).Select
                '== Границы занятого информацией поля листа == Start ===
                Set iDiapazon = .UsedRange
                With iDiapazon
                    nREnd = .Row + .Rows.Count - 1
                    nCEnd = .Column + .Columns.Count - 1
                End With
                Set iDiapazon = Nothing
                '== Границы занятого информацией поля листа == Stop ====
                i = 0
                For i = nREnd To 1 Step -1
                    stroka = ""
                    stroka = .Cells(i, 1).Text
                    If InStr(1, stroka, "Регион", vbTextCompare) > 0 Then
                        stanc = ""
                        stanc = .Cells(i + 1, 1).Text
                       
                        Set bl = Range(.Cells(4, 4), .Cells(4, 46))
                        dtMin = Format(CDate(Application.Min(bl)), "dd.mm.yyyy")
                        dtMax = Format(CDate(Application.Max(bl)), "dd.mm.yyyy")
                        Set bl = Nothing
                       
'                        Set bl = Range(.Cells(i + 25, 4), .Cells(i + 25, 46))
'                        dnRZMS = Application.SumIf(bl, 0)
'Stop
                        MsgBox "Найден информационный блок по " & stanc, vbExclamation + vbOKOnly, "для " & stroka
                       
                        With ThisWorkbook.Worksheets("Сводный")
                            .Cells(nRTo, 2) = stroka
                            .Cells(nRTo, 3) = stanc
                            .Cells(nRTo, 4) = CStr(dtMin) & " - " & CStr(dtMax)
                        End With
                       
                        nRTo = nRTo + 1
                    End If
                Next i
               
                MsgBox "Активен лист " & .Name & Chr(10) & Chr(10) & _
                       "Справочно:" & Chr(10) & _
                       "Информация расположена в границах:" & Chr(10) & _
                       "     - строки: с 1-ой по " & CStr(nREnd) & "-ю;" & Chr(10) & _
                       "     - колонки: c 1-ой по " & CStr(nCEnd) & "-ю;", vbInformation + vbOKOnly, "Местоположение:"
               
            End With
        End If
    Next
   
    ThisWorkbook.Worksheets("Сводный").Activate
End Sub


Путей к вершине - множество. Этот один из многих!

Che79

Уважаемые форумчане!
Задача снова очень актуальна..Сможет ли кто-то помочь?
Заранее спасибо.
Делай нормально и будет нормально!

Gior

А если так... (См. комментарий к ячейке N1 на листе "AllData")

Che79

Спасибо, идея хороша!
Но желательно выводить данные именно в той русскоязычной форме, которая задана, ну и самое главное, у меня в 2003-м макрос не работает:(
Может, еще варианты есть?

Делай нормально и будет нормально!

nilem

Как понял, на сводном листе нужны именно формулы, а не значения. Попробуйте так - для примера формулы заполняются в первых 5 столбцах, итоговая таблица выводится в диапазон, начиная с А23. Зеленая стрелка.

Che79

здОрово, спасибо, только при добавлении еще одного листа, скажем,"декабрь" макрос работать перестает и в сводной данные добавленного листа не отображаются...
И потом, насколько я понял предложенный Вами макрос отображает только часть данных.Как можно отобразить все необходимые данные?
Делай нормально и будет нормально!

nilem

Попробовал вставить еще 3 листа - в итоговой таблице появились дополнительно 3 блока.
А вообще, раз уж все листы такие одинаковые: копируем в новое место блок формул, например, за сентябрь - Ctrl+F - Найти "сент" - Заменить "окт" - Заменить все - Ок.