Архив

Публикации с меткой ‘Как сделать?’

Как просуммировать данные с нескольких листов, в том числе по условию

В данной статье я хочу рассказать, как можно просуммировать данные на одном листе из других листов. К примеру: на листах Январь, Февраль и Март расположены данные по продажам, а под ними итог. Допустим, это будет ячейка D7. Если структура всех таблиц одинакова(одинаковое кол-во строк, товара, различается) и Итог расположен во всех таблицах в одной ячейке, то можно воспользоваться простой формулой:

=СУММ(Январь:Март!D7)

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

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

Function All_SumIf(rRange As Range, rCriteria As Range, rSumRange As Range, Optional bAllSh As Boolean = True)
    Dim wsSh As Worksheet, sRange As String, sSumRange As String
    sRange = Right(rRange.Address, Len(rRange.Address) - InStr(rRange.Address, "!"))
    sSumRange = Right(rSumRange.Address, Len(rSumRange.Address) - InStr(rSumRange.Address, "!"))
    For Each wsSh In Sheets
        If bAllSh Then
            If wsSh.Name <> Application.Caller.Parent.Name Then
                All_SumIf = All_SumIf + Application.SumIf(wsSh.Range(sRange), rCriteria, wsSh.Range(sSumRange))
            End If
        Else
            If wsSh.Index < Application.Caller.Parent.Index Then
                All_SumIf = All_SumIf + Application.SumIf(wsSh.Range(sRange), rCriteria, wsSh.Range(sSumRange))
            End If
        End If
    Next wsSh
End Function
Function All_SumIf(rRange As Range, rCriteria As Range, rSumRange As Range, Optional bAllSh As Boolean = True)
    Dim wsSh As Worksheet, sRange As String, sSumRange As String
    sRange = Right(rRange.Address, Len(rRange.Address) - InStr(rRange.Address, "!"))
    sSumRange = Right(rSumRange.Address, Len(rSumRange.Address) - InStr(rSumRange.Address, "!"))
    For Each wsSh In Sheets
        If bAllSh Then
            If wsSh.Name <> Application.Caller.Parent.Name Then
                All_SumIf = All_SumIf + Application.SumIf(wsSh.Range(sRange), rCriteria, wsSh.Range(sSumRange))
            End If
        Else
            If wsSh.Index < Application.Caller.Parent.Index Then
                All_SumIf = All_SumIf + Application.SumIf(wsSh.Range(sRange), rCriteria, wsSh.Range(sSumRange))
            End If
        End If
    Next wsSh
End Function

Чтобы правильно воспользоваться кодом советую прочитать статью: Что такое функция пользователя(UDF)?

Аргументы функции аналогичны стандартной СУММЕСЛИ, только в конце добавлен еще один, необязательный.

rRange - Ссылка на диапазон ячеек. Указывается диапазон значений, среди которых необходимо искать критерий.
rCriteria - Ссылка на одну ячейку. Указывается ячейка, в которой содержится значение, данные по которому надо просуммировать.
rSumRange - Ссылка на диапазон ячеек. Указывается диапазон сумм или чисел, которые необходимо просуммировать на основании критерия.
bAllSh - Необязательный аргумент. Если не указан, или указано значение 1 или ИСТИНА, то будут суммироваться значения со всех листов, кроме листа, на котором записана функция. Если указано значение 0 или ЛОЖЬ, то будут суммироваться значения с листов, расположенных до листа, на котором записана функция.

Применение обех функций вы найдете в примере к статье.

Скачать пример »

  Tips_All_SumIf_Few_Sheets.xls (54,0 KiB, 12 скачиваний)

Как вернуть меню в стиле Excel 2003 в версиях 2007 и старше

25 Февраль 2012 2 comments

С приходом в нашу жизнь нового Excel 2007 в неё также пришли не только свыше миллиона строк, почти неограниченное количество условий условного форматирования и еще куча новых возможностей, но и новый стиль. Притом не просто новый, а совершенно переработанный, незнакомый, неузнаваемый и запутывающий. Кто-то годами пользовался 2003 Excel и настолько привык к его интерфейсу, что новый стиль был воспринят не просто в штыки — многие из этих людей до сих пор пользуются 2003 практически только из-за нежелания переходить на новый стиль.
Тем, кто боится перейти на новый интерфейс только по этой причине, а так же тем, кого мучает ностальгия по прежнему интерфейсу могу предложить несложный код, который на вкладке «Надстройки» создает ряд меню, повторяющих старый добрый 2003.

Сам код:

Sub MakeMenu2003()
    Dim objCmndBr As CommandBar, objMenu03 As CommandBar, objCtrl As CommandBarControl
    Dim avArr, li As Long
    'Удаляем меню, если оно уже создано
    On Error Resume Next
    Application.CommandBars("Меню 2003").Delete
    On Error GoTo 0
    'Для английской локализации
'    avArr = Array("&File", "&Edit", "&View", "&Insert", "F&ormat", "&Tools", "&Data", "&Window", "&Help")
    'Для русской локализации
    avArr = Array("Фа&йл", "&Правка", "&Вид", "Вст&авка", "Фор&мат", "С&ервис", "&Данные", "&Окно", "&Справка")
    'Создаем панель на которой будут контролы со старым видом меню
    Set objMenu03 = Application.CommandBars.Add("Меню 2003", , False)
    'Создаем контролы путем копирования групп меню целиком
    For li = LBound(avArr) To UBound(avArr)
        Application.CommandBars("Built-in Menus").Controls(avArr(li)).Copy objMenu03
    Next li
    'Делаем меню видимым
    Application.CommandBars("Меню 2003").Visible = True
End Sub
Sub MakeMenu2003()
    Dim objCmndBr As CommandBar, objMenu03 As CommandBar, objCtrl As CommandBarControl
    Dim avArr, li As Long
    'Удаляем меню, если оно уже создано
    On Error Resume Next
    Application.CommandBars("Меню 2003").Delete
    On Error GoTo 0
    'Для английской локализации
'    avArr = Array("&File", "&Edit", "&View", "&Insert", "F&ormat", "&Tools", "&Data", "&Window", "&Help")
    'Для русской локализации
    avArr = Array("Фа&йл", "&Правка", "&Вид", "Вст&авка", "Фор&мат", "С&ервис", "&Данные", "&Окно", "&Справка")
    'Создаем панель на которой будут контролы со старым видом меню
    Set objMenu03 = Application.CommandBars.Add("Меню 2003", , False)
    'Создаем контролы путем копирования групп меню целиком
    For li = LBound(avArr) To UBound(avArr)
        Application.CommandBars("Built-in Menus").Controls(avArr(li)).Copy objMenu03
    Next li
    'Делаем меню видимым
    Application.CommandBars("Меню 2003").Visible = True
End Sub

Учитывайте, что созданная панель будет существовать даже после закрытия файла и даже после закрытия Excel.
На всякий случай я добавил в код массив наименований меню для английской локализации офиса, т.к. не у всех может оказаться действительно русская локализация или кто-то просто принципиально пользуется английской.
Так же прилагаю файл, в котором можно нажатием кнопок создать меню и удалить. Для тех, кто незнаком с макросами: прежде чем попробовать создать меню с помощью выложенного здесь файла настоятельно рекомендую прочесть эту статью: Почему не работает макрос?

Конечно, это не лучший вариант и если поискать в сети, то можно найти программы, которые так же воссоздают меню в стиле 2003, но почти все они платные.

Скачать пример »

  Tips_All_MakeMenu2003.xls (44,5 KiB, 129 скачиваний)

Как из Excel обратиться к другому приложению

Иногда бывает необходимо перенести что-то из Excel в другое приложение. Я возьму для примера Word. Например скопировать ячейки и вставить. Обычно мы это так и делаем — скопировали в Excel, открыли Word — вставили. Но сделать это при помощи кода чуть сложнее, хотя если разобраться никаких сложностей нет. Ниже приведен пример кода, который открывает Word, открывает в нем определенный документ, копирует данные из Excel и вставляет в открытый документ Word.

Sub OpenWord()
    Dim objWrdApp As Object, objWrdDoc As Object
    'создаем новое приложение Word
    Set objWrdApp = CreateObject("Word.Application")
    'Можно так же сделать приложение Word видимым. По умолчанию открывается в скрытом режиме
    'objWrdApp.Visible = True
    'открываем документ Word - документ "Doc1.doc" должен существовать
    Set objWrdDoc = objWrdApp.Documents.Open("C:\Doc1.doc")
    'Копируем из Excel диапазон "A1:A10"
    Range("A1:A10").Copy
    'вставляем скопированные ячейки в Word - в начала документа
    objWrdDoc.Range(0).Paste
    'закрываем документ Word с сохранением
    objWrdDoc.Close True    ' False - без сохранения
    'закрываем приложение Word - обязательно!
    objWrdApp.Quit
    'очищаем переменные Word - обязательно!
    Set objWrdDoc = Nothing: Set objWrdApp = Nothing
End Sub
Sub OpenWord()
    Dim objWrdApp As Object, objWrdDoc As Object
    'создаем новое приложение Word
    Set objWrdApp = CreateObject("Word.Application")
    'Можно так же сделать приложение Word видимым. По умолчанию открывается в скрытом режиме
    'objWrdApp.Visible = True
    'открываем документ Word - документ "Doc1.doc" должен существовать
    Set objWrdDoc = objWrdApp.Documents.Open("C:\Doc1.doc")
    'Копируем из Excel диапазон "A1:A10"
    Range("A1:A10").Copy
    'вставляем скопированные ячейки в Word - в начала документа
    objWrdDoc.Range(0).Paste
    'закрываем документ Word с сохранением
    objWrdDoc.Close True    ' False - без сохранения
    'закрываем приложение Word - обязательно!
    objWrdApp.Quit
    'очищаем переменные Word - обязательно!
    Set objWrdDoc = Nothing: Set objWrdApp = Nothing
End Sub

В файле-примере, приложенном к данной статье, в комментариях к коду есть несколько добавлений. Например, как вставить текст из ячеек в опрделенные закладки Word-а и как добавить новый документ, а не открывать уже имеющийся. Так же так есть код проверки — открыто ли приложение Word в данный момент. Порой это тоже может пригодиться, чтобы работать с запущенным приложением Word, а не создавать новое:

Sub Check_OpenWord()
    Dim objWrdApp As Object
    On Error Resume Next
    'пытаемся подключится к объекту Word
    Set objWrdApp = GetObject(, "Word.Application")
    If objWrdApp Is Nothing Then
        'если приложение закрыто - создаем новый экземпляр
        Set objWrdApp = CreateObject("Word.Application")
        'делаем приложение видимым. По умолчанию открывается в скрытом режиме
        objWrdApp.Visible = True
    Else
        'приложение открыто - выдаем сообщение
        MsgBox "Приложение Word уже открыто", vbInformation, "Check_OpenWord"
    End If
End Sub
Sub Check_OpenWord()
    Dim objWrdApp As Object
    On Error Resume Next
    'пытаемся подключится к объекту Word
    Set objWrdApp = GetObject(, "Word.Application")
    If objWrdApp Is Nothing Then
        'если приложение закрыто - создаем новый экземпляр
        Set objWrdApp = CreateObject("Word.Application")
        'делаем приложение видимым. По умолчанию открывается в скрытом режиме
        objWrdApp.Visible = True
    Else
        'приложение открыто - выдаем сообщение
        MsgBox "Приложение Word уже открыто", vbInformation, "Check_OpenWord"
    End If
End Sub

В принципе, активировать или вызвать(если закрыто) другое приложение Офиса можно одной строкой:

Sub Open_AnotherApp()
    Application.ActivateMicrosoftApp xlMicrosoftWord
End Sub
Sub Open_AnotherApp()
    Application.ActivateMicrosoftApp xlMicrosoftWord
End Sub

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

По сути, методами CreateObject и GetObject можно обратиться к любому стороннему приложению(например Internet Explorer). Куда важнее при обращении к этим объектам знать объектную модель того приложения, к которому обращаетесь. Чтобы увидеть свойства и методы объектной модели приложения, можно в редакторе VBA подключить необоходимую библиотеку, объявить переменную, назначив ей тип приложения. Покажу на примере того же Word-а.
Для начала открываем меню Tools-References:

Подключаем библиотеку:

Затем объявляем переменную и присваиваем ей тип нужного приложения:

Sub OpenWord()
    Dim objWrdApp As Word.Application
    Set objWrdApp = New Word.Application
    objWrdApp.Visible = True
End Sub
Sub OpenWord()
    Dim objWrdApp As Word.Application
    Set objWrdApp = New Word.Application
    objWrdApp.Visible = True
End Sub

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

Так же можно нажать F2 и через поиск найти Word и просмотреть все методы и свойства данного приложения.

Скачать пример »

  Tips_Macro_OpenWord.xls (49,5 KiB, 112 скачиваний)

Categories: Tags: ,

Как отменить действия макроса

Рано или поздно каждый, кто программирует в VBA задается вопросом: а можно ли отменить действия, совершенные макросом? Для начала надо понять, в каких ситуациях это нам надо. Если вдруг Вы выполнили код, который испортил или удалил Ваши данные в файле. Но Вам эти данные еще нужны и Вы думаете, как же можно все вернуть. Самой простое, что можно сделать это закрыть файл без сохранения и открыть заново. Все данные будут на месте(если, конечно, в коде не было строки, сохраняющей файл). Второй способ: это перед выполнением макроса делать резервную копию файла — тогда Ваши исходные данные всегда будут целы.




Но как же сделать отмену действий макроса через стандартную кнопку на панели или сочетанием клавиш Ctrl+Z и можно ли? Ответ — можно. Но сразу вопрос: а насколько это нужно? В каких ситуациях это может пригодиться? Я вот так вот навскидку сразу не сказал бы, если бы не являлся разработчиком программ и надстроек в среде Microsoft Excel. Именно в надстройках отмена действий наиболее востребована, на мой взгляд. Например надстройка объединяет ячейки. Объединили случайно и…В стандартной ситуации после такого макроса нельзя отменить действия. Закрывать файл без сохранения? Как-то некрасиво получается, если продукт является коммерческим. И тогда приходится извращаться и пытаться сделать возможным отмену действий макроса. В моей надстройке MyAddin в некоторых командах отмена действий команд как раз и применяется. Но ближе к делу, точнее к коду:

'Создаем свой пользовательский тип данных
Type SaveRange
    vFormula As Variant
    sAddr As String
    lColor As Long
End Type
'Переменные для запоминания данных
Public wbWBook As Workbook
Public wsSh As Worksheet
Public vOldVals() As SaveRange
'---------------------------------------------------------------------------------------
' Procedure : Fill_Numbers
' Purpose   : Основная процедура. Это тот код, который вносит изменения на лист
'             и действия которого нам необходимо отменить
'             Процедура заполняет выделенные ячейки номерами
'             и изменяет цвет заливки
'---------------------------------------------------------------------------------------
Sub Fill_Numbers()
    Dim rCell As Range, li As Long
    '   Сначала запоминаем значения выделенных ячеек на листе
    ReDim vOldVals(1 To Selection.Count)
    'Запоминаем активную книгу
    'это на случай, если отмена действий будет производиться из другой книги
    Set wbWBook = ActiveWorkbook
    'Запоминаем активный лист
    'на случай, если отмена действий будет производиться из другого листа
    Set wsSh = ActiveSheet
    'Запоминаем значения(заносим в массив)
    li = 1
    For Each rCell In Selection
        'запоминаем адрес ячейки
        vOldVals(li).sAddr = rCell.Address
        'запоминаем формулу(если нет формулы - значение)
        vOldVals(li).vFormula = rCell.Formula
        'запоминаем цвет заливки ячейки
        vOldVals(li).lColor = rCell.Interior.Color
        li = li + 1
    Next rCell
    '======================================
    'Выполняем основные действия(собственно тот код, который надо будет отменить)
    li = 1
    For Each rCell In Selection
        rCell = li
        rCell.Interior.ColorIndex = li
        li = li + 1
    Next rCell
    '======================================
    'Назначаем стандартному вызову отмены действий выполнение нашего макроса возвращения значений
    Application.OnUndo "Отменить заполнение ячеек номерами", "Restore_Vals"
End Sub
 
'---------------------------------------------------------------------------------------
' Procedure : Restore_Vals
' Purpose   : Процедура отмены действия(возврат значений)
'---------------------------------------------------------------------------------------
Sub Restore_Vals()
    Dim li As Long
    'В случае непредвиденной ошибки переходим на метку
    'и показываем сообщение об ошибке
    On Error GoTo Erreble
    'Активируем книгу, в которой были сделаны изменения
    wbWBook.Activate
    'Активируем лист, в котором были сделаны изменения
    wsSh.Activate
    'Возвращаем значения
    For li = 1 To UBound(vOldVals)
        Range(vOldVals(li).sAddr).Formula = vOldVals(li).vFormula
        Range(vOldVals(li).sAddr).Interior.Color = vOldVals(li).lColor
    Next li
    Exit Sub
 
    'Показываем сообщение о невозможности отмены действия
Erreble:
    MsgBox "Нельзя отменить действие!", vbCritical, "Error"
End Sub
'Создаем свой пользовательский тип данных
Type SaveRange
    vFormula As Variant
    sAddr As String
    lColor As Long
End Type
'Переменные для запоминания данных
Public wbWBook As Workbook
Public wsSh As Worksheet
Public vOldVals() As SaveRange
'---------------------------------------------------------------------------------------
' Procedure : Fill_Numbers
' Purpose   : Основная процедура. Это тот код, который вносит изменения на лист
'             и действия которого нам необходимо отменить
'             Процедура заполняет выделенные ячейки номерами
'             и изменяет цвет заливки
'---------------------------------------------------------------------------------------
Sub Fill_Numbers()
    Dim rCell As Range, li As Long
    '   Сначала запоминаем значения выделенных ячеек на листе
    ReDim vOldVals(1 To Selection.Count)
    'Запоминаем активную книгу
    'это на случай, если отмена действий будет производиться из другой книги
    Set wbWBook = ActiveWorkbook
    'Запоминаем активный лист
    'на случай, если отмена действий будет производиться из другого листа
    Set wsSh = ActiveSheet
    'Запоминаем значения(заносим в массив)
    li = 1
    For Each rCell In Selection
        'запоминаем адрес ячейки
        vOldVals(li).sAddr = rCell.Address
        'запоминаем формулу(если нет формулы - значение)
        vOldVals(li).vFormula = rCell.Formula
        'запоминаем цвет заливки ячейки
        vOldVals(li).lColor = rCell.Interior.Color
        li = li + 1
    Next rCell
    '======================================
    'Выполняем основные действия(собственно тот код, который надо будет отменить)
    li = 1
    For Each rCell In Selection
        rCell = li
        rCell.Interior.ColorIndex = li
        li = li + 1
    Next rCell
    '======================================
    'Назначаем стандартному вызову отмены действий выполнение нашего макроса возвращения значений
    Application.OnUndo "Отменить заполнение ячеек номерами", "Restore_Vals"
End Sub

'---------------------------------------------------------------------------------------
' Procedure : Restore_Vals
' Purpose   : Процедура отмены действия(возврат значений)
'---------------------------------------------------------------------------------------
Sub Restore_Vals()
    Dim li As Long
    'В случае непредвиденной ошибки переходим на метку
    'и показываем сообщение об ошибке
    On Error GoTo Erreble
    'Активируем книгу, в которой были сделаны изменения
    wbWBook.Activate
    'Активируем лист, в котором были сделаны изменения
    wsSh.Activate
    'Возвращаем значения
    For li = 1 To UBound(vOldVals)
        Range(vOldVals(li).sAddr).Formula = vOldVals(li).vFormula
        Range(vOldVals(li).sAddr).Interior.Color = vOldVals(li).lColor
    Next li
    Exit Sub

    'Показываем сообщение о невозможности отмены действия
Erreble:
    MsgBox "Нельзя отменить действие!", vbCritical, "Error"
End Sub

Комментарии к коду я старался сделать максимально подробными, поэтому думаю, что больше нечего разъяснять. К тому по древней традиции я приложил к статье пример с данным кодом :) Единственное, что могу добавить: пользовательский тип SaveRange может быть дополнен еще какими-либо переменными, помимо vFormula, sAddr и lColor. Например цвет границ ячейки, цвет шрифта и т.д. Все зависит от того, какие изменения Вы будете делать кодом и что захотите затем вернуть.

Скачать пример »

  Tips_Restore_Macro.xls (48,5 KiB, 62 скачиваний)




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

'Переменные для запоминания данных
Public wbWBook As Workbook
Public wsSh As Worksheet, wsActSh As Worksheet, sSh_Name As String, lShPoz As Long
'---------------------------------------------------------------------------------------
' Procedure : Fill_Numbers
' Purpose   : Основная процедура. Это тот код, который вносит изменения на лист
'             и действия которого нам необходимо отменить
'             Процедура заполняет выделенные ячейки номерами
'             и изменяет цвет заливки
'---------------------------------------------------------------------------------------
Sub Fill_Numbers()
    Dim rCell As Range, li As Long
    'Запоминаем активную книгу
    'это на случай, если отмена действий будет производиться из другой книги
    Set wbWBook = ActiveWorkbook
    'Запоминаем активный лист
    'на случай, если отмена действий будет производиться из другого листа
    Set wsActSh = ActiveSheet
    lShPoz = wsActSh.Index
    sSh_Name = wsActSh.Name
    Application.ScreenUpdating = 0
    wsActSh.Copy , wbWBook.Sheets(wbWBook.Sheets.Count)
    Set wsSh = wbWBook.Sheets(wbWBook.Sheets.Count)
    wsSh.Visible = xlVeryHidden
    wsActSh.Activate
    Application.ScreenUpdating = 1
    '======================================
    'Выполняем основные действия(собственно тот код, который надо будет отменить)
    li = 1
    For Each rCell In Selection
        rCell = li
        rCell.Interior.ColorIndex = li
        li = li + 1
    Next rCell
    '======================================
    'Назначаем стандартному вызову отмены действий выполнение нашего макроса возвращения значений
    Application.OnUndo "Отменить заполнение ячеек номерами", "Restore_Vals"
End Sub
 
'---------------------------------------------------------------------------------------
' Procedure : Restore_Vals
' Purpose   : Процедура отмены действия(возврат значений)
'---------------------------------------------------------------------------------------
Sub Restore_Vals()
    'В случае непредвиденной ошибки переходим на метку
    'и показываем сообщение об ошибке
    On Error GoTo Erreble
    Application.ScreenUpdating = 0
    'Активируем книгу, в которой были сделаны изменения
    wbWBook.Activate
    'делаем видимым резервный лист
    wsSh.Visible = -1
    'Удаляем исходный лист, данные в котором уже изменены
    Application.DisplayAlerts = 0
    wsActSh.Delete
    Application.DisplayAlerts = 1
    'назначаем резервному листу имя исходного
    wsSh.Name = sSh_Name
    wsSh.Move wbWBook.Sheets(lShPoz)
    'Активируем резервный лист
    wsSh.Activate
    Application.ScreenUpdating = 0
    Exit Sub
    'Показываем сообщение о невозможности отмены действия
Erreble:
    MsgBox "Нельзя отменить действие!", vbCritical, "Error"
End Sub
'Переменные для запоминания данных
Public wbWBook As Workbook
Public wsSh As Worksheet, wsActSh As Worksheet, sSh_Name As String, lShPoz As Long
'---------------------------------------------------------------------------------------
' Procedure : Fill_Numbers
' Purpose   : Основная процедура. Это тот код, который вносит изменения на лист
'             и действия которого нам необходимо отменить
'             Процедура заполняет выделенные ячейки номерами
'             и изменяет цвет заливки
'---------------------------------------------------------------------------------------
Sub Fill_Numbers()
    Dim rCell As Range, li As Long
    'Запоминаем активную книгу
    'это на случай, если отмена действий будет производиться из другой книги
    Set wbWBook = ActiveWorkbook
    'Запоминаем активный лист
    'на случай, если отмена действий будет производиться из другого листа
    Set wsActSh = ActiveSheet
    lShPoz = wsActSh.Index
    sSh_Name = wsActSh.Name
    Application.ScreenUpdating = 0
    wsActSh.Copy , wbWBook.Sheets(wbWBook.Sheets.Count)
    Set wsSh = wbWBook.Sheets(wbWBook.Sheets.Count)
    wsSh.Visible = xlVeryHidden
    wsActSh.Activate
    Application.ScreenUpdating = 1
    '======================================
    'Выполняем основные действия(собственно тот код, который надо будет отменить)
    li = 1
    For Each rCell In Selection
        rCell = li
        rCell.Interior.ColorIndex = li
        li = li + 1
    Next rCell
    '======================================
    'Назначаем стандартному вызову отмены действий выполнение нашего макроса возвращения значений
    Application.OnUndo "Отменить заполнение ячеек номерами", "Restore_Vals"
End Sub

'---------------------------------------------------------------------------------------
' Procedure : Restore_Vals
' Purpose   : Процедура отмены действия(возврат значений)
'---------------------------------------------------------------------------------------
Sub Restore_Vals()
    'В случае непредвиденной ошибки переходим на метку
    'и показываем сообщение об ошибке
    On Error GoTo Erreble
    Application.ScreenUpdating = 0
    'Активируем книгу, в которой были сделаны изменения
    wbWBook.Activate
    'делаем видимым резервный лист
    wsSh.Visible = -1
    'Удаляем исходный лист, данные в котором уже изменены
    Application.DisplayAlerts = 0
    wsActSh.Delete
    Application.DisplayAlerts = 1
    'назначаем резервному листу имя исходного
    wsSh.Name = sSh_Name
    wsSh.Move wbWBook.Sheets(lShPoz)
    'Активируем резервный лист
    wsSh.Activate
    Application.ScreenUpdating = 0
    Exit Sub
    'Показываем сообщение о невозможности отмены действия
Erreble:
    MsgBox "Нельзя отменить действие!", vbCritical, "Error"
End Sub

Скачать пример »

  Tips_Restore_Macro_HiddenSh.xls (45,0 KiB, 50 скачиваний)

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

Как запретить сообщения?

 

Может быть кому-то эта статья покажется лишней, кому-то странной, но…Спрос на данную тему достаточно велик и поэтому статья вообще появилась. Тем, кто программирует на VBA приходится делать разнообразные вещи, среди которых используются вызовы стандартных Excel-вских команд и методов. Команды в свою очередь могут выдавать сообщения, которые совершенно не нужны при выполнении кода. Яркий пример — удаление листа из книги. При попытке удаления листа появляется запрос:

Все бы ничего, но при выполнении кода подобные сообщения «стопорят» код. К примеру ниже приведен код удаления листа:

Sub Del_Sheet()
    ActiveSheet.Delete
    MsgBox "Лист удален(или нет, смотря что Вы нажали)", vbInformation, "www.excel-vba.ru"
End Sub
Sub Del_Sheet()
    ActiveSheet.Delete
    MsgBox "Лист удален(или нет, смотря что Вы нажали)", vbInformation, "www.excel-vba.ru"
End Sub

Запустите его и увидите, что приходится нажимать «Да», чтобы код продолжился. Не совсем удобно, особенно когда надо обойти штук 10 таких сообщений минимум. Проблема устраняется очень просто:

Sub Del_Sheet()
    Application.DisplayAlerts = False
    ActiveSheet.Delete
    MsgBox "Лист удален", vbInformation, "www.excel-vba.ru"
    Application.DisplayAlerts = True
End Sub
Sub Del_Sheet()
    Application.DisplayAlerts = False
    ActiveSheet.Delete
    MsgBox "Лист удален", vbInformation, "www.excel-vba.ru"
    Application.DisplayAlerts = True
End Sub

Команда Application.DisplayAlerts = False »подавляет» показ системных сообщений. Это касается практически всех сообщений Excel, даже тех, что появляются перед закрытием книги без сохранения. К чему я это пишу? К тому, что следует помнить, что необходимо всегда возвращать значение данного свойства в True. Иначе может получиться так, что код Вы выполнили, все хорошо. Но значение не вернули. И тогда Вы рискуете следствие случайного нажатия того же удаления листа вместо привычного предупрждения просто лишиться листа. А попытавшись закрыть книгу без сохранения, чтобы заново открыть и вернуть лист — не увидеть стандартного вопроса: «Сохранить изменения в книге?»

Categories: Tags:

Как запустить файл с включенными макросами?

22 Октябрь 2011 4 comments

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

Вариант 1:
Самый простой и легко исполняемый способ. Создаете в нужной книге новый лист. Называете его «WARNING». На листе мы пишем инструкцию по действиям пользователя для включения макросов. Что-то типа:
Для работы с файлом требуется разрешить макросы!
Excel 2003:Сервис-Безопасность-Уровень макросов «Низкий»
Excel 2007:Меню-Параметры Excel-Центр управления безопасностью-Параметры центра управления безопасностью-Параметры макросов-Разрешить все макросы.

И скрываем все листы в книге, кроме листа «WARNING». Теперь в остается дело за мылым: в модуль книги вставляете следующий код:

'Данная процедура скрывает перед закрытием книги все листы,
'кроме листа "WARNING"
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Application.ScreenUpdating = False
    Dim wsSh As Worksheet
    Sheets("WARNING").Visible = -1
    For Each wsSh In ThisWorkbook.Sheets
        If wsSh.Name <> "WARNING" Then wsSh.Visible = 2
    Next wsSh
    ThisWorkbook.Save
End Sub
'Данная процедура показывает перед открытием книги все листы,
'кроме листа "WARNING"
Private Sub Workbook_Open()
    Dim wsSh As Worksheet
    For Each wsSh In ThisWorkbook.Sheets
        wsSh.Visible = -1
    Next wsSh
    ThisWorkbook.Sheets("WARNING").Visible = 2
End Sub
'Данная процедура скрывает перед закрытием книги все листы,
'кроме листа "WARNING"
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Application.ScreenUpdating = False
    Dim wsSh As Worksheet
    Sheets("WARNING").Visible = -1
    For Each wsSh In ThisWorkbook.Sheets
        If wsSh.Name <> "WARNING" Then wsSh.Visible = 2
    Next wsSh
    ThisWorkbook.Save
End Sub
'Данная процедура показывает перед открытием книги все листы,
'кроме листа "WARNING"
Private Sub Workbook_Open()
    Dim wsSh As Worksheet
    For Each wsSh In ThisWorkbook.Sheets
        wsSh.Visible = -1
    Next wsSh
    ThisWorkbook.Sheets("WARNING").Visible = 2
End Sub

Из кода видно, что если макросы будут отключены, то код Workbook_Open не будет выполнен. Следовательно пользователь увидит только лист «WARNING», на котором у нас написаны инструкции по включению макросов, которые ему в любом случае придется выполнить, если есть желание работать с файлом.

Вариант 2:
Этот способ подразумевает создание отдельного файла, который будет запускать файл Excel. Я предоставлю на выбор либо скрипт VBS, либо созданный мной файл EXE. В чем прелесть. При использовании данного способа совершенно неважно запущен ли уже у пользователя Excel или нет, разрешены ли макросы. Скрипт или EXE сам все запустит и разрешит.
Что такое скрипт VBS? Это обычный текстовый файл, сохраненный с расширением VBS. Такой файл распознается операционной системой как исполняемый и код, расположенный в нем, запускается при двойном щелчке на файле. Чтобы создать такой файл необходимо: создать обычный текстовый файл. Открыть его. Записать в него текст:

test
Sub test()
    Dim objXL
    Dim Secur
    Set objXL = CreateObject("Excel.Application")
    objXL.Visible = TRUE
    secur = objXL.AutomationSecurity
    objXL.AutomationSecurity = 1
    objXL.Workbooks.Open replace(Wscript.ScriptFullName,".vbs",".xls"),,,,"4321"
    objXL.AutomationSecurity = secur
End Sub
test
Sub test()
    Dim objXL
    Dim Secur
    Set objXL = CreateObject("Excel.Application")
    objXL.Visible = TRUE
    secur = objXL.AutomationSecurity
    objXL.AutomationSecurity = 1
    objXL.Workbooks.Open replace(Wscript.ScriptFullName,".vbs",".xls"),,,,"4321"
    objXL.AutomationSecurity = secur
End Sub

Сохранить. Поменять расширение текстового файла с .txt на .vbs.

Если не отображается расширение:
Панель управления-Свойства папки(для Win 7 — Параметры папок)-вкладка «Вид»-Снять галочку с «Скрывать расширение для зарегистрированных типов файлов»

Скрипт запускает файл Excel, имя которого совпадает с именем скрипта и расположенного в той же папке. В примере к статье это файл «Test». Таким образом Вы можете давать любое имя файлу Excel и файлу скрипта, лишь бы они совпадали. Т.е. назвав скрипт «Run», Вы должны будете и файл Excel назвать так же — «Run». В приведенном коде так же есть возможность указать пароль для открытия файла. Это сделано для того, чтобы при попытке запустить файл Excel без скрипта был запрошен пароль. Т.е. без скрипта файлом не воспользоваться.
Плюсы использования скрипта:

  • пользователь совершает минимум действий;
  • макросы разрешены как ни крутись.

Минусы:

  • необходимость создания отдельного файла и привязка к имени;
  • возможность подсмотреть пароль к файлу, просто сменив расширение файла-скрипта на .txt;
  • возможность сменить/снять пароль к файлу после его открытия скриптом(можно избежать, внеся некоторый код в файл. Например сохранять только с нужным паролем). В примере пароль к файлу: 4321


Файл EXE. Долго пояснять не буду. Основные моменты все те же, что и со скриптом, т.к. в принципе это одно и то же, за исключением того, что код файла EXE нельзя подсмотреть, просто сменив расширение. Создается этот файл в специальной программной среде: С++, VisualBasic, VisualStudio и т.п. Основной минус: нельзя поменять пароль к файлу, не скомпилировав новый файл EXE. Т.е. если планируете использовать не с одним файлом, то надо всем им давать один и то же пароль, либо вообще не устанавливать пароль на открытие.

В примере Вы найдете файлы для всех описанных способов.

Скачать пример »

  Run_Wit_Macro.zip (28,1 KiB, 333 скачиваний)

Также см.:
Почему не работает макрос?
Управление безопасностью макросов

Categories: Tags: ,

Функция СУММЕСЛИ, а так же СУММЕСЛИ по двум критериям

 

Думаю, для начала неплохо было бы пояснить, что такое СУММЕСЛИ(это для тех, кто не знает).
СУММЕСЛИ – Суммирует ячейки, удовлетворяющие заданному условию. Всего для СУММЕСЛИ предусмотрено три аргумента: Диапазон, Критерий, Диапазон_Суммирования.

=СУММЕСЛИ(A1:A20000;A1;B1:B20000)

Диапазон(A1:A20000) — указывается диапазон с критериями. Т.е. столбец, в котором искать значение, указанное аргументом Критерий.
Критерий(A1)- значение(текстовое или числовое, а так же дата), которое необходимо найти в Диапазоне. Может содержать символы подстановки «*» и «?». Т.е. указав в качестве Критерия «*масса*» Вы сможете просуммировать по значениями, в которых встречается слово «масса». А указав «масса*» — значения, начинающиеся на «масса». «?» — заменяет лишь один символ, т.е. указав «мас?а» вы сможете просуммировать строки и со значением «масса» и со значением «маска» и т.д.
Все текстовые критерии и критерии с логическими и математическими знаками необходимо заключать в двойные кавычки («). Если критерием является число, использовать кавычки не требуется. Если требуется найти непосредственно вопросительный знак или звездочку, необходимо поставить перед ним знак «тильды» (~).
Диапазон_Суммирования (B1:B20000)(необязательный аргумент) — указывается диапазон сумм или числовых значений, которые необходимо просуммировать.
Сначала поясню общий момент: функция ищет в Диапазоне значение, указанное аргументом Критерий, и при находждении совпадения суммирует данные, указанные аргументом Диапазон_Суммирования. Т.е. если у Вас в столбце А название отдела, а в столбце В суммы, то указав в качестве критерия «Отдел развития», то результатом функции будет сумма всех значений столбца В, напротив которых в столбце А встречается «Отдел развития». Диапазон_Суммирования может не совпадать по размеру с аргументом Диапазон. Однако при определении ячеек для суммирования, в качестве начальной ячейки для суммирования будет использована верхняя левая ячейка аргумента Диапазон_Суммирования, а затем суммируются ячейки, соответствующие по размеру и форме аргументу Диапазон.
Теперь некоторые особенности. Последний аргумент функции(Диапазон_Суммирования) является необязательным. А это значит, что его можно не указывать. Если его не указать, то функция просуммирует значения, указанные аргументом Диапазон. Для чего это нужно. Например, Вам необходимо получить сумму только тех чисел, которые больше нуля. В столбце А суммы. Тогда фунция будет иметь такой вид:

=СУММЕСЛИ(A1:A20000;">0")


Но что делать, когда критериев для суммирования 2 и больше? Можно, конечно, воспользоваться функцией СУММЕСЛИМН, но…Она появилась только в версиях Excel, начиная с 2007. А как же быть несчастным пользователям более ранних версий? Очень просто: использовать другую функцию — СУММПРОИЗВ. Не буду расписывать аргументы, т.к. их много и все они являются массивами значений. Данная функция перемножает массивы, указанные аргументами.
Допустим, Вам надо просуммировать только те суммы, которые относятся к одному отделу и только за определенную дату. Тогда функция будет выглядеть так:

=СУММПРОИЗВ(($A$2:$A$50=$I$3)*($B$2:$B$50=H5);$C$2:$C$50)

$A$2:$A$50 — диапазон дат. $I$3 — дата критерия, за которую необходимо просуммировать данные.
$B$2:$B$50 — наименования отделов. H5 — наименование отдела, данные по которому необходимо просуммировать.
$C$2:$C$50 — диапазон с суммами.

Разберем логику, т.к. многим она будет совершенно не ясна просто при взгляде на данную функцию. Хотя бы потому, что в справке подобное её применение не описывается. Для большей читабельности уменьшим размеры диапазонов:

=СУММПРОИЗВ(($A$2:$A$5=$I$3)*($B$2:$B$5=H5);$C$2:$C$5)

Итак, выражение ($A$2:$A$5=$I$3) и ($B$2:$B$5=H5) являются логическими и возвращают массивы логических ЛОЖЬ и ИСТИНА. ИСТИНА, если ячейка диапазона $A$2:$A$5 равна значению ячейки $I$3 и ячейка диапазона $B$2:$B$5 равна значению ячейки H5. Т.е. получается у нас следующее:

=СУММПРОИЗВ({ЛОЖЬ;ИСТИНА;ИСТИНА;ЛОЖЬ}*{ЛОЖЬ;ЛОЖЬ;ИСТИНА;ЛОЖЬ};$C$2:$C$50)

Как видно, в первом массиве два совпадения условию, а во втором одно. Далее эти два массива перемножаются(за это отвечает знак умножения(*)). При перемножения происходит неявное преобразование массивов ЛОЖЬ и ИСТИНА в числовые константы 0 и 1 соответственно({0;1;1;0}*{0;0;1;0}). Как известно, при умножении на нуль получаем нуль. И в результате получается один массив:

=СУММПРОИЗВ({0;0;1;0};$C$2:$C$50)

Далее происходит уже перемножение массива {0;0;1;0} на массив чисел в диапазоне $C$2:$C$50:

=СУММПРОИЗВ({0;0;1;0};{10;20;30;40})

И как результат получаем 30. Что нам и требовалось — мы получаем лишь ту сумму, которая соответствует критерию. Если сумм, удовлетворяющих критерию будет больше одной, то они будут просуммированы.
В примере найдете пару примеров функций для более лучшего понимания написанного выше.

Скачать пример »

  Tips_All_SUMPRODUCT.xls (29,5 KiB, 1 354 скачиваний)

Так же см.:
Summ_CellColor - Суммирование ячеек по цвету заливки
Summ_CellFont - Суммирование ячеек по цвету шрифта
Summ_CellFormat - Суммирование ячеек по формату ячейки

Как удалить макросы в книге?

 

Рано или поздно у разработчиков возникает вопрос: как удалить макросы, в том числе и из книги, в которой эти макросы расположены? Да еще так, чтобы об этом никто ничего не узнал? С одной стороны — это довольно просто сделать при помощи кода VBA:

Sub Delete_Macroses()
    Dim oVBComponent As Object, lCountLines As Long
    'Проверяем, защищен проект или нет
    If ActiveWorkbook.VBProject.Protection = 1 Then
        MsgBox "VBProject выбранной книги защищён." & vbCrLf & _
             "     Компоненты не будут удалены.", vbExclamation, "Отмена выполнения"
        Exit Sub
    End If
 
    For Each oVBComponent In ActiveWorkbook.VBProject.VBComponents
        On Error Resume Next
        With oVBComponent
            Select Case .Type
            Case 1    'Модули
                .Collection.Remove oVBComponent
            Case 2    'Модули Класса
                .Collection.Remove oVBComponent
            Case 3    'Формы
                .Collection.Remove oVBComponent
            Case 100    'ЭтаКнига, Листы
                    lCountLines = .CodeModule.CountOfLines
                    .CodeModule.DeleteLines 1, lCountLines
            End Select
        End With
    Next
    Set oVBComponent = Nothing
End Sub
Sub Delete_Macroses()
    Dim oVBComponent As Object, lCountLines As Long
    'Проверяем, защищен проект или нет
    If ActiveWorkbook.VBProject.Protection = 1 Then
        MsgBox "VBProject выбранной книги защищён." & vbCrLf & _
             "     Компоненты не будут удалены.", vbExclamation, "Отмена выполнения"
        Exit Sub
    End If

    For Each oVBComponent In ActiveWorkbook.VBProject.VBComponents
        On Error Resume Next
        With oVBComponent
            Select Case .Type
            Case 1    'Модули
                .Collection.Remove oVBComponent
            Case 2    'Модули Класса
                .Collection.Remove oVBComponent
            Case 3    'Формы
                .Collection.Remove oVBComponent
            Case 100    'ЭтаКнига, Листы
                    lCountLines = .CodeModule.CountOfLines
                    .CodeModule.DeleteLines 1, lCountLines
            End Select
        End With
    Next
    Set oVBComponent = Nothing
End Sub
  • Но есть два момента:
    Доверие к проекту VBA должно быть проставлено 

    1. Excel 2007Меню-Параметры Excel-Центр управления безопасностью-Параметры макросов-поставить галочку «Доверять доступ к объектной модели проектов VBA»;
    2. Excel 2003СервисПараметры-вкладка Безопасность-Параметры макросов-Доверять доступ к Visual Basic Project
  • проект не должен быть защищен.

Исключить первое условие никак нельзя программно(хотя вру, конечно, можно. Но весьма непросто и в этой статье я не буду все это описывать и рассказывать). А вот как снять пароль с проекта VBA я уже рассказывал в статье Как программно снять пароль с VBA проекта?.
Так же можно удалить макросы только из одного компонента(листа или книги или модуля). В качестве примера возьмем Лист1:

Sub Delete_Macroses_In_One_Comp()
    Dim oVBComponent As Object, lCountLines As Long
    Set oVBComponent = ActiveWorkbook.VBProject.VBComponents("Лист1")
    With oVBComponent
        lCountLines = .CodeModule.CountOfLines
        .CodeModule.DeleteLines 1, lCountLines
    End With
    Set oVBComponent = Nothing
End Sub
Sub Delete_Macroses_In_One_Comp()
    Dim oVBComponent As Object, lCountLines As Long
    Set oVBComponent = ActiveWorkbook.VBProject.VBComponents("Лист1")
    With oVBComponent
        lCountLines = .CodeModule.CountOfLines
        .CodeModule.DeleteLines 1, lCountLines
    End With
    Set oVBComponent = Nothing
End Sub

Здесь тоже есть небольшая поправка: Лист1 — это кодовое(внутреннее имя) листа. На ярлычке имя листа может отображаться как угодно, а вот внутренее…Его можно поменять лишь из VBA:


Еще хочу добавить, что если Вам надо не скрыто, а просто быстро удалить все макросы из книги и Вы счастливый обладатель Excel версии 2007 и выше, то Вам всего лишь необходимо книгу, из которой хотите удалить макросы, Сохранить как-обычная Книга Excel(Меню-Сохранить как-Книга Excel).

Также см.:
Копирование модулей и форм из одной книги в другую
Как программно снять пароль с VBA проекта?

Categories: Tags:

Как массово изменить гиперссылки?

 

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

Существуют ситуации, когда на листе есть много гиперссылок на различные папки или интернет ресурсы. И вот случилось вдруг так, что адреса надо поменять(либо домен сменился, либо на сервере добавилась директория и эти изменения надо отразить в гиперссылках). Для примера возьмем такие исходные данные: надо заменить текст «.excel_vba» на текст «excel-vba«.
Тут все зависит от того, каким способом установлена гиперссылка. Если установлена через формулу ГИПЕРССЫЛКА, то все просто:

  1. выделяем диапазон с гиперссылками;
  2. жмем Ctrl+H.
    • Найти: .excel_vba
    • Заменить на: excel-vba
    • Жмете кнопочку «Параметры» и устанавливаете Область поискаФормулы и снимаете галочку «Ячейка целиком«.
  3. Жмете «Заменить все«

Теперь адреса ссылок должны поменяться.
Все гораздо хуже, если гиперссылки у Вас созданы через стандартное меню: правый клик мыши на ячейке — Гиперссылка. Тут фокус с заменой через Ctrl+H не пройдет. Но зато можно применить такой код:

Sub Replace_Hyperlink()
    Dim rCell As Range, rRange As Range, sWhatRep As String, sRep As String
    On Error Resume Next
    Set rRange = Application.InputBox("Укажите диапазон для замены", "Выбор данных", Type:=8)
    If rRange Is Nothing Then Exit Sub
    sWhatRep = InputBox("Что меняем?", "Ввод данных", ".excel_vba")
    sRep = InputBox("На что меняем?", "Ввод данных", "excel-vba")
    If sWhatRep = "" Then Exit Sub
    If sRep = "" Then
        If MsgBox("Хотите заменить " & sWhatRep & " на пусто?", vbCritical + vbYesNo, "Предупреждение") = vbNo Then Exit Sub
    End If
    Application.ScreenUpdating = 0
    For Each rCell In rRange
        If rCell.Hyperlinks.Count > 0 Then
            If rCell.Hyperlinks(1).Address = rCell.Value Then
                rCell = Replace(rCell.Value, sWhatRep, sRep)
            End If
            rCell.Hyperlinks(1).Address = Replace(rCell.Hyperlinks(1).Address, sWhatRep, sRep)
        End If
    Next rCell
    Application.ScreenUpdating = 1
End Sub
Sub Replace_Hyperlink()
    Dim rCell As Range, rRange As Range, sWhatRep As String, sRep As String
    On Error Resume Next
    Set rRange = Application.InputBox("Укажите диапазон для замены", "Выбор данных", Type:=8)
    If rRange Is Nothing Then Exit Sub
    sWhatRep = InputBox("Что меняем?", "Ввод данных", ".excel_vba")
    sRep = InputBox("На что меняем?", "Ввод данных", "excel-vba")
    If sWhatRep = "" Then Exit Sub
    If sRep = "" Then
        If MsgBox("Хотите заменить " & sWhatRep & " на пусто?", vbCritical + vbYesNo, "Предупреждение") = vbNo Then Exit Sub
    End If
    Application.ScreenUpdating = 0
    For Each rCell In rRange
        If rCell.Hyperlinks.Count > 0 Then
            If rCell.Hyperlinks(1).Address = rCell.Value Then
                rCell = Replace(rCell.Value, sWhatRep, sRep)
            End If
            rCell.Hyperlinks(1).Address = Replace(rCell.Hyperlinks(1).Address, sWhatRep, sRep)
        End If
    Next rCell
    Application.ScreenUpdating = 1
End Sub

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

Скачать пример »

  Tips_Macro_ReplaceHyperlinks.xls (46,0 KiB, 516 скачиваний)

Так же см.:
Что такое гиперссылка?

Categories: Tags:

Как удалить строки по условию?

 

Как часто Вам приходится удалять строки в таблицах? Я не имею ввиду все строки, нет. Это просто. Как удалить только определенные строки? У Вас большая таблица и Вы хотите удалить из неё только те строки, определенные ячейки которых содержать то или иное слово(цифру, фразу). Можно воспользоваться несколькими способами. я опишу пару из них.

Способ первый: воспользоваться встроенным фильтром. Для начала его необходимо установить:

  • Выделяем таблицу с данными, включая заголовки. Если их нет — то выделяете с самой первой строки таблицы, в которой необходимо удалить данные
  • устанавливаете филльтр:
    для Excel 2003: Данные-Фильтр-Автофильтр
    для Excel 2007: вкладка Данные-Фильтр(или вкладка Главная-Сортировка и фильтр-Фильтр)

Теперь выбираем условие для фильтра:

в Excel 2003 надо выбрать Условие и в появившейся форме выбрать непосредственно условие(«равно», «содержит», «начинается с» и т.д.), а напротив значение в соответствии с условием.
Для 2007 Excel нужно выбрать Текстовые фильры и либо сразу выбрать одно из предлагаемых условий, либо нажать «Настраиваемый фильтр» и там так же, как в 2003 ввести значения в форме.

После этого удалить отфильтрованные строки. В 2007 Excel могут возникнуть проблемы с удалением отфильтрованных строк, поэтому рекомендую сначала так же прочитать статью: Excel удаляет вместо отфильтрованных строк - все?! Как избежать.

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

Sub Del_SubStr()
    Dim sSubStr As String 'искомое слово или фраза(может быть указанием на ячейку)
    Dim lCol As Long 'номер столбца с просматриваемыми значениями
    Dim lLastRow As Long, li As Long
    Dim lMet As Long
 
    sSubStr = InputBox("Укажите значение, которое необходимо найти в строке", "Запрос параметра", "")
    If sSubStr = "" Then lMet = 0 Else lMet = 1
    lCol = Val(InputBox("Укажите номер столбца, в котором искать указанное значение", "Запрос параметра", 1))
    If lCol = 0 Then Exit Sub
 
    lLastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
 
    Application.ScreenUpdating = 0
    For li = lLastRow To 1 Step -1
        If InStr(Cells(li, lCol), sSubStr) = lMet Then Rows(li).Delete
    Next li
    Application.ScreenUpdating = 0
End Sub
Sub Del_SubStr()
    Dim sSubStr As String 'искомое слово или фраза(может быть указанием на ячейку)
    Dim lCol As Long 'номер столбца с просматриваемыми значениями
    Dim lLastRow As Long, li As Long
    Dim lMet As Long

    sSubStr = InputBox("Укажите значение, которое необходимо найти в строке", "Запрос параметра", "")
    If sSubStr = "" Then lMet = 0 Else lMet = 1
    lCol = Val(InputBox("Укажите номер столбца, в котором искать указанное значение", "Запрос параметра", 1))
    If lCol = 0 Then Exit Sub

    lLastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count

    Application.ScreenUpdating = 0
    For li = lLastRow To 1 Step -1
        If InStr(Cells(li, lCol), sSubStr) = lMet Then Rows(li).Delete
    Next li
    Application.ScreenUpdating = 0
End Sub

Если значение sSubStr не будет указано, то будут удалены строки, ячейки указанного столбца которых, пустые.
Данный код необходимо поместить в стандартный модуль. Вызвать с листа его можно нажатием клавиш Alt+F8, после чего выбрать Del_SubStr и нажать Выполнить. Если в данном коде в строке

If InStr(Cells(li, lCol), sSubStr) = lMet Then Rows(li).Delete
If InStr(Cells(li, lCol), sSubStr) = lMet Then Rows(li).Delete

вместо = lMet указать <> lMet, то удаляться будут строки, не содержащие указанное для поиска значение. Иногда тоже удобно.
Но. Данный код просматривает строки на предмет частичного совпадения указанного значения. Например, если Вы укажете текст для поиска «отчет», то будут удалены все строки, в которых встречается это слово(«квартальный отчет», «отчет за месяц» и т.д.). Это не всегда нужно. Поэтому ниже приведен код, который будет удалять только строки, указанные ячейки которых равны конкретно указанному значению:

Sub Del_SubStr()
    Dim sSubStr As String 'искомое слово или фраза(может быть указанием на ячейку)
    Dim lCol As Long 'номер столбца с просматриваемыми значениями
    Dim lLastRow As Long, li As Long
 
    sSubStr = InputBox("Укажите значение, которое необходимо найти в строке", "Запрос параметра", "")
    lCol = Val(InputBox("Укажите номер столбца, в котором искать указанное значение", "Запрос параметра", 1))
    If lCol = 0 Then Exit Sub
 
    lLastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
 
    Application.ScreenUpdating = 0
    For li = lLastRow To 1 Step -1
        If Cstr(Cells(li, lCol)) = sSubStr Then Rows(li).Delete
    Next li
    Application.ScreenUpdating = 0
End Sub
Sub Del_SubStr()
    Dim sSubStr As String 'искомое слово или фраза(может быть указанием на ячейку)
    Dim lCol As Long 'номер столбца с просматриваемыми значениями
    Dim lLastRow As Long, li As Long

    sSubStr = InputBox("Укажите значение, которое необходимо найти в строке", "Запрос параметра", "")
    lCol = Val(InputBox("Укажите номер столбца, в котором искать указанное значение", "Запрос параметра", 1))
    If lCol = 0 Then Exit Sub

    lLastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count

    Application.ScreenUpdating = 0
    For li = lLastRow To 1 Step -1
        If Cstr(Cells(li, lCol)) = sSubStr Then Rows(li).Delete
    Next li
    Application.ScreenUpdating = 0
End Sub

Здесь так же, как и в случае с предыдущим кодом можно заменить оператор сравнения(Cells(li, lCol) = sSubStr) с равно на неравенство(Cells(li, lCol) <> sSubStr) и тогда удаляться будут строки, значения ячеек которых не равно указанному.

Так же см.:
Удаление всех пустых строк в таблице
Удаление пустых столбцов на листе
Установить Быстрый фильтр
Фильтр

Categories: Tags: