Авторизация

Рубрики блога


Рекомендуем



Последние комментарии

Облако тегов


Устами великих

"Странный этот мир, где двое смотрят на одно и то же, а видят полностью противоположное." © Агата Кристи

Мы Вконтакте

MS Office и VBA Рубрика содержит интересные решения, малоизвестные функции и возможности, надстройки и макросы, в общем, все то, что может сделать вашу работу в пакете программ MS Office (в первую очередь - Excel, Word, Access) более эффективной.
20
Ноя

Применение функции к выделенным ячейкам с помощью макроса

рейтинг материал 0.0 (0) | количество просмотров 6022 | количество коментариев 0
Рассмотрим, как добавить с помощью макроса эксель (VBA) в выделенную ячейку (диапазон) необходимую формулу, например округления, учитывая содержимое ячейки.
Download source

Порой, когда необходимо обработать большой массив данных, имея дело с шаблонами, где протягивание формул не вариант, приходится каждую ячейку обрабатывать вручную. Одним из примеров такой ситуации, является применение формулы округления для части ячеек, которые в шаблоне чередуются с текстовыми заголовками. Формула функции округления (ОКРУГЛ), помимо ссылки на ячейку, имеет еще параметр Число разрядов, если проставлять это все вручную, то это довольно затратно по времени. На помощь в таких случаях могут прийти макросы, которые автоматом выполняют шаблонные действия и освобождают порой кучу времени.

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

Макрос ОкруглЯчейка – добавляет формулу округления в выделенную ячейку

Первое, что подсказывает логика, это просто обратиться к выделенной ячейке через ActiveCell и задать ее содержимое как переменную cont, затем обратиться еще раз к активной ячейке и принудительно изменить ее содержимое, которое будет включать необходимую часть формулы с переменной cont:

cont = ActiveCell.Formula
ActiveCell.Formula = "=ROUND(" & cont & ",2)"

Суть правильная, но необходимо учесть несколько условий, которые уменьшат выдачу ошибки или бессмысленное выполнение макроса. К примеру, если в ячейке уже есть пусть простейшая формула =A1+B1, то применение вышеописанного макроса выдаст ошибку в ячейке, так как будет два знака равно. То есть, необходимо добавить проверку содержимого ячейки на наличие формулы и если какая-либо формула есть, то содержимое такой ячейки нужно обрезать на крайний слева символ, то есть знак равно, вот вариант:

ravno = Left(ActiveCell.Formula, 1) 'определяем первый слева символ из содержимого активной ячейки как переменную ravno
If ravno Like "=" Then
 cont = Right(ActiveCell.Formula, Len(ActiveCell.Formula) - 1) 'если переменная ravno содержит знак равно, обрезаем содержимое ячейки на один символ слева и только затем определяем как переменную cont
Else
 cont = ActiveCell.Formula 'в обратном случае обрезать ничего не нужно и полностью все содержимое ячейки определяем как переменную cont
End If

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

If cont Like "*ROUND*" Or cont Like "*CEILING*" Or cont Like "*FLOOR*" Then
 MsgBox "Уже есть округление" 'в случае, если в содержимом активной ячейки имеются части слов ROUND, CEILING или FLOOR, функция округления не добавляется, а лишь выводится окошко с уведомлением
Else
 ActiveCell.Formula = "=ROUND(" & cont & ",2)" 'в обратном случае, в ячейку добавляется функция округления до второго разряда
End If

Итоговый вариант макроса, учитывающий вышеперечисленные условия, будет выглядеть так:

Sub ОкруглЯчейка()
' Макрос для проставки формулы округления до двух знаков после запятой для активной ячейки

Dim ravno, cont
'проверка на наличие формулы в ячейке, и обрезание содержимого на знак равно, в случае если формула есть
ravno = Left(ActiveCell.Formula, 1)
If ravno Like "=" Then
 cont = Right(ActiveCell.Formula, Len(ActiveCell.Formula) - 1)
Else
 cont = ActiveCell.Formula
End If

'проверка на наличие формулы округления в ячейке
If cont Like "*ROUND*" Or cont Like "*CEILING*" Or cont Like "*FLOOR*" Then
 MsgBox "Уже есть округление"
Else
 ActiveCell.Formula = "=ROUND(" & cont & ",2)"
End If
End Sub

Макрос ОкруглДиапаз_2 – добавляет формулу округления в выделенный диапазон

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

'определяем координаты выделенного диапазона
lRow = Selection.Row 'номер первой строки
lLastRow = Selection.Row + Selection.Rows.Count - 1 'номер последней строки
lCol = Selection.Column 'номер первого столбца
lLastCol = Selection.Column + Selection.Columns.Count - 1 'номер последнего столбца

Определили номера первых и последних строк и столбцов, чего нам достаточно, чтобы задать диапазон с помощью Cells(), теперь нужен двойной цикл, который пройдет по каждой ячейке диапазона:

Dim a1, b1 As Integer
For a1 = lCol To lLastCol
 For b1 = lRow To lLastRow
 Cells(b1, a1) = 1 'любое действие для каждой ячейки диапазона, в качестве примера, в каждой ячейке проставляется единица 
 Next b1
Next a1

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

Sub ОкруглДиапаз_2()

'определяем координаты выделенного диапазона
lRow = Selection.Row 'номер первой строки
lLastRow = Selection.Row + Selection.Rows.Count - 1 'номер последней строки
lCol = Selection.Column 'номер первого столбца
lLastCol = Selection.Column + Selection.Columns.Count - 1 'номер последнего столбца

Dim a1, b1 As Integer
For a1 = lCol To lLastCol
 For b1 = lRow To lLastRow 
Dim ravno, cont
'проверка на наличие формулы в ячейке, и обрезание содержимого на знак равно, в случае если формула есть
ravno = Left(Cells(b1, a1).Formula, 1)
If ravno Like "=" Then
 cont = Right(Cells(b1, a1).Formula, Len(Cells(b1, a1).Formula) - 1)
Else
 cont = Cells(b1, a1).Formula
End If

'проверка на наличие формулы округления в ячейке
If cont Like "*ROUND*" Or cont Like "*CEILING*" Or cont Like "*FLOOR*" Then
 MsgBox "Уже есть округление"
Else
 Cells(b1, a1).Formula = "=ROUND(" & cont & ",2)"
End If
 Next b1
Next a1
End Sub

Макрос ОкруглДиапаз – добавляет формулу округления в выделенный диапазон, учитывая тип данных

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

Чтобы задавать разрядность воспользуемся InputBox и зададим его значение как переменную myValue:

Dim myValue As Variant
myValue = InputBox("Введите целое число, определяющее разряд округления (количество знаков после запятой)", "Число разрядов", 2)

Чтобы указать условие, учитывающее тип данных, можно воспользоваться TypeName:

If TypeName(Cells(b1, a1).Value) = "String" Then
 MsgBox "В ячейке присутствует текст"
Else
 MsgBox "В ячейке другой тип данных"
End If

Теперь соберем в кучу прошлый макрос и эти вышеперечисленные дополнения, чтобы получить тот самый универсальный макрос, который бы хотелось получить:

Sub ОкруглДиапаз()
'
'определяем координаты выделенного диапазона
lRow = Selection.Row 'номер первой строки
lLastRow = Selection.Row + Selection.Rows.Count - 1 'номер последней строки
lCol = Selection.Column 'номер первого столбца
lLastCol = Selection.Column + Selection.Columns.Count - 1 'номер последнего столбца

'определяем количество знаков после запятой
Dim myValue As Variant
myValue = InputBox("Введите целое число, определяющее разряд округления (количество знаков после запятой)", "Число разрядов", 2)

Dim a1, b1 As Integer
For a1 = lCol To lLastCol
 For b1 = lRow To lLastRow
 Dim ravno, cont
'проверка на наличие формулы округления в ячейке
 ravno = Left(Cells(b1, a1).Formula, 1)
 If ravno Like "=" Then
 cont = Right(Cells(b1, a1).Formula, Len(Cells(b1, a1).Formula) - 1)
 Else
 cont = Cells(b1, a1).Formula
 End If
 
'проверка на наличие текста в ячейке
If TypeName(Cells(b1, a1).Value) = "String" Then
 ‘MsgBox "В ячейке присутствует текст"
Else
'проверка на наличие формулы округления в ячейке
 If cont Like "*ROUND*" Or cont Like "*CEILING*" Or cont Like "*FLOOR*" Then
 'MsgBox "Уже есть округление"
 Else
 Cells(b1, a1).Formula = "=ROUND(" & cont & "," & myValue & ")"
 End If
End If
 
 Next b1
Next a1

End Sub
Download source
Добавлять комментарии могут только зарегистрированные пользователи.
[ Регистрация | Вход ]