Несколько полезных макросов - Макросы в Excel

Очень нужные две строчки! Запретить обновление экрана и выскакивание окон-предупреждений.

Ускоряют работу макроса в разы, особенно если макрос много перемещается по документу, или еще хуже, перескакивает с одного документа на другой. В самом начале макроса пишем:

    Application.DisplayAlerts = False

    Application.ScreenUpdating = False

Не забудьте в самом конце макроса вернуть параметры обратно в рабочее состояние.

    Application.DisplayAlerts = True

    Application.ScreenUpdating = True

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

Удалить строку, в которой в первом столбце нет данных (ячейка пуста)

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

    i=2

    Do While Cells(i,2)<>""    ' пока во второй не пусто

       If Cells(i,1)="" then        ' если в первой пусто

          Rows(i).Delete

          i=i-1    ' нужно, чтобы вернуться на строку выше, так как база сдвинулась

       End if

    i=i+1

    Loop

Копирование данных из множества файлов в один

Допустим, у нас есть ежедневная выгрузка по продажам, каждый день в отдельном файле. Мы хотим свести всю информация в один. Для этого сложим все файлы в отдельную папку, создадим в другой папке сводный файл и выполним следующий макрос:

      ' указываем путь к папке, не забываем \ в конце пути, иначе будет ошибка

      fpath = "C:\Documents and Settings\Svod\"      

      ' получаем имя первого файла

      dr = Dir("C:\Documents and Settings\Svod\", vbNormal)

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

      nach = 2

      ' делаем до тех пор, пока файлы есть

      Do While dr <> ""

          Workbooks.Open (fpath & dr)

          Workbooks(dr).Activate

          i = 2

          ' находим конец данных

          Do While Cells(i, 1) <> ""

              i = i + 1

          Loop

          i = i - 1

          ' копируем и вставляем в сводный файл

          Range(Cells(2, 1), Cells(i, 11)).Copy

          Workbooks("сводный.xlsx").Activate

          Cells(nach, 1).Select

          ActiveSheet.Paste

          ' меняем строку для вставки данных в сводном файле

          nach = nach + i - 1

          ' закрываем переработанный файл

          Workbooks(dr).Close

          ' запоминаем имя следующего файла в папке

          dr = Dir()

      Loop

Перебор всех сводный таблиц во всех листах книги

Иногда нужно пройтись по всем сводным таблицам в книге и изменить в каждой что-нибудь, например, поменять значение фильтра. Легче всего это сделать с помощью цикла For Each

Сначала мы делаем внешний цикл для пробежки по всем листам. Внутрь этого  цикла помещаем другой цикл, который пробегает по всем таблицам на листе.

    For Each sh In Sheets

        sh.Activate

        For Each pvt In PivotTables

            ....

        Next pvt

    Next sh

Писать название переменной после слова Next не обязательно, но полезно, если у вас несколько циклов. Так код становится намного читабельнее.

Замена фильтров в кубах

На этом примере мы разберем, как получать выставленные значения фильтра и ставить новые.

Рассмотрим такую задачу: у вас есть очень много кубов, в которых используется измерение "Категория товара". В некоторых кубах оно стоит в строках, в некоторых в фильтре, причем где-то выбрана одна категория (множественный выбор не разрешен), где-то несколько. В вашей компании что-то поменялось и товары перегруппировали, сделав в кубах новое измерение "Подразделение бизнеса", но с той же сутью и вы точно можете сопоставить значения старого и нового фильтров. Как заменить старые фильтры на новые автоматически?

Как пробегать по всем кубам в книге уже описано здесь, поэтому опустим эту часть. Рассмотри, что нам нужно делать для каждого найденного куба. Можно все эти действия поместить в функцию, это сделало бы код чуть менее громоздким и чуть более читаемым.

Для начала запишем названия наших фильтров в переменные. Для этого нужно сделать с ними какое-нибудь действие с включенным макрорекордером

filt = "[Категория товара].[Категория товара]"

filt_new = "[Подразделение бизнеса].[Подразделение бизнеса]"

Итак, перед нами новый куб. В нём может использоваться измерение, а может и нет

    ' получаем расположение старого фильтра

    orient = pvt.CubeFields(filt).Orientation

Если фильтра в кубе нет, его позиция будет равна 0. Тогда нам не надо ничего менять в этом кубе

    If orient <> 0 Then

Получаем список проставленных позиций. Тут допустим, что позиции проставлены только на одном уровне иерархии. Иначе нам нужно было бы получать список для каждого уровня

        arr = pvt.CubeFields(filt).PivotFields("[Категория товара].[Категория товара].[LV1]").VisibleItemsList

Но такая запись работает, только если разрешен множественный выбор. Если он не разрешен, arr окажется пустым. Тогда ситуацию, когда он не разрешен, обработаем отдельно.

        If arr(1) = "" Then

            arr(1) = pvt.PivotFields("[Категория товара].[Категория товара].[LV1]").CurrentPageName

        End If

Далее нам нужно сопоставить каждому значению текущего фильтра значение из нового фильтра. Это можно сделать, например, на листе Excel написав таблицу сопоставлений и обратившись к ней. Так и сделаем. Для каждого элемента из имеющегося массива сделаем следующие действия

        For Each ar In arr

            ' в значение массива записывается и имя поля, оно нам вряд ли нужно, поэтому отрежем лишнее

            ar_new = Mid(ar, 51, Len(ar) - 51)

   ' бежим по таблице сопоставления

   k=2

            Do While Workbooks("Книга.xls").Sheets("Лист1").Cells(k, 2) <> ""

                ' когда находим нужный, записываем значение нового фильтра в новый массив. Не забываем добавить название поля

                If Workbooks("Книга.xls").Sheets("Лист1").Cells(k, 2) = ar_new Then

                     t = t + 1

                     ReDim Preserve brr(t)

                     brr(t) = "[Подразделение бизнеса].[Подразделение бизнеса].&[" & Workbooks("Книга.xls").Sheets("Лист1").Cells(k, 3) & "]"

                End If

                k = k + 1

            Loop

        Next

Теперь у нас есть новый массив значений. мы убираем старый фильтр, ставим на его место новый и выставляем значения фильтра

        pvt.CubeFields(filt).Orientation = 0

        pvt.CubeFields(filt_new).Orientation = orient

        On Error Resume Next

        pvt.CubeFields(filt_new).EnableMultiplePageItems = True

        ' очищаем старые значения на всякий случай

        pvt.CubeFields(filt_new).ClearManualFilter

        ' для всех уровней проставляем массив

        pvt.PivotFields("[Подразделение бизнеса].[Подразделение бизнеса].[LV2]").VisibleItemsList = brr

        pvt.PivotFields("[Подразделение бизнеса].[Подразделение бизнеса].[LV3]").VisibleItemsList = Array("")

        pvt.PivotFields("[Подразделение бизнеса].[Подразделение бизнеса].[LV4]").VisibleItemsList = Array("")

        End If

End If

Отправка открытого файла Excel через Outlook

Да, отправку открытой книги Excel можно сделать и имеющимися в нём средствами, но в 2013 Office кнопка отправки расположена так. что нужно сделать 4 клика, чтобы до неё добраться. Кроме того, как говорится, дьявол кроется в мелочах: при стандартной отправке не подтягивается стандартная подпись к письму, а в тему письма попадает название файла вместе с расширением, что некрасиво.

Поэтому я делаю макрос, который размещаю на кнопке на панели инструментов (или даже в меню быстрого доступа), таким образом получаю возможность отправлять файл в 1-2 клика. Плюс я могу настроить подпись, тему и тело письма, могу даже сразу вбить получателя. Так что этот вариант немного более приятный, чем стандартный.

У меня подпись подтягивается сама, поэтому мне не пришлось делать дополнительных настроек. А в тему письма я помещаю название файла, но без расширения

    Dim OutApp As Object

    Dim OutMail As Object    

    ActiveWorkbook.Save

    ' отрезаем от названия книги расширение

    book_name = ActiveWorkbook.Name

    c = ""

    Do While c <> "." And Len(book_name) > 0

        c = Right(book_name, 1)

        book_name = Left(book_name, Len(book_name) - 1)

    Loop

    ' открываем Outlook

    Set OutApp = CreateObject("Outlook.Application")

    Set OutMail = OutApp.CreateItem(0)

    ' создаем письмо

    With OutMail

        .CC = ""

        .BCC = ""

        .Subject = book_name

        .Attachments.Add ActiveWorkbook.FullName

        .Display

    End With