Всем привет! С помощью макрорекордера создал макрос для умножения числового диапазона ячеек на значение, вводимое в определённую ячейку. При вводе каждого следующего множителя, значения ячеек диапазона сначала возвращаются к начальным значениям, а потом уже умножаются на новый множитель. Свои функции этот макрос, конечно выполняет, но во время его работы в глазах рябит от перескакивания с листа на лист. Можно ли его как-нибудь оптимизировать, чтобы функционировал покрасивше?
Всем привет! С помощью макрорекордера создал макрос для умножения числового диапазона ячеек на значение, вводимое в определённую ячейку. При вводе каждого следующего множителя, значения ячеек диапазона сначала возвращаются к начальным значениям, а потом уже умножаются на новый множитель. Свои функции этот макрос, конечно выполняет, но во время его работы в глазах рябит от перескакивания с листа на лист. Можно ли его как-нибудь оптимизировать, чтобы функционировал покрасивше?Xpert
Здравствуйте, дамы и господа. Немного подкорректировал и оптимизировал свой макрос, но столкнулся с проблемой: при указании фиксированных диапазонов ячеек, всё работает нормально(см."Пример"), а если вводить именованный диапазон, выскакивает ошибка(см. "Пример(именован)"). Дело в том, что точно неизвестно, какой диапазон будет применим в тех или иных случаях, поэтому мне нужно, чтобы макрос ориентировался именно на динамический(изменяющийся) а не на фиксированный диапазон. Подскажите, можно ли это как-то реализовать?
Здравствуйте, дамы и господа. Немного подкорректировал и оптимизировал свой макрос, но столкнулся с проблемой: при указании фиксированных диапазонов ячеек, всё работает нормально(см."Пример"), а если вводить именованный диапазон, выскакивает ошибка(см. "Пример(именован)"). Дело в том, что точно неизвестно, какой диапазон будет применим в тех или иных случаях, поэтому мне нужно, чтобы макрос ориентировался именно на динамический(изменяющийся) а не на фиксированный диапазон. Подскажите, можно ли это как-то реализовать?Xpert
Xpert, здравствуйте. Диапазон у Вас строится на листе1, а в макросе вы его ищете на листе2. Еще нужно проверить, содержит ли диапазон ячейки, например так: [vba]
Код
On Error Resume Next Set x = Sheets("Лист1").Range("Диапазон") Debug.Print IsEmpty(x)
[/vba]
Xpert, здравствуйте. Диапазон у Вас строится на листе1, а в макросе вы его ищете на листе2. Еще нужно проверить, содержит ли диапазон ячейки, например так: [vba]
Код
On Error Resume Next Set x = Sheets("Лист1").Range("Диапазон") Debug.Print IsEmpty(x)
Manyasha, InExSu, спасибо. Сделал как вы сказали, ошибка исчезла...по отдельности каждый макрос(Макрос и Copie) работает, а вот с модуля листа не запускаются. В модуле листа код такой:
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False Dim rng As Range: Set rng = [C1] On Error Resume Next Set x = Sheets("Лист1").Range("Диапазон") Debug.Print IsEmpty(x) If Not Intersect(rng, Target) Is Nothing Then Макрос If Not Intersect(x, Target) Is Nothing Then Call copie Application.EnableEvents = True End Sub
[/vba]
Макрос:
[vba]
Код
Sub Макрос() Dim arr1(), arrRes() Dim i As Long arr1() = Sheets("Лист1").Range("Данные").Value ReDim arrRes(1 To UBound(arr1, 1), 1 To 1) For i = 1 To UBound(arr1, 1) Step 1 arrRes(i, 1) = arr1(i, 1) * (1 + Range("C1").Value) Next i Sheets("Лист1").Range("A2").Resize(UBound(arrRes, 1)).Value = arrRes() End Sub
[/vba]
и макрос Copie
[vba]
Код
Sub copie() Application.ScreenUpdating = False Application.CutCopyMode = False Application.DisplayAlerts = False On Error Resume Next Set x = Sheets("Лист1").Range("Данные") Debug.Print IsEmpty(x) x.copy Sheets("Лист2").Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Sheets("Лист1").Select Application.ScreenUpdating = False Application.CutCopyMode = False Application.DisplayAlerts = False End Sub
[/vba]
Голову сломал, но не получается.
Manyasha, InExSu, спасибо. Сделал как вы сказали, ошибка исчезла...по отдельности каждый макрос(Макрос и Copie) работает, а вот с модуля листа не запускаются. В модуле листа код такой:
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False Dim rng As Range: Set rng = [C1] On Error Resume Next Set x = Sheets("Лист1").Range("Диапазон") Debug.Print IsEmpty(x) If Not Intersect(rng, Target) Is Nothing Then Макрос If Not Intersect(x, Target) Is Nothing Then Call copie Application.EnableEvents = True End Sub
[/vba]
Макрос:
[vba]
Код
Sub Макрос() Dim arr1(), arrRes() Dim i As Long arr1() = Sheets("Лист1").Range("Данные").Value ReDim arrRes(1 To UBound(arr1, 1), 1 To 1) For i = 1 To UBound(arr1, 1) Step 1 arrRes(i, 1) = arr1(i, 1) * (1 + Range("C1").Value) Next i Sheets("Лист1").Range("A2").Resize(UBound(arrRes, 1)).Value = arrRes() End Sub
[/vba]
и макрос Copie
[vba]
Код
Sub copie() Application.ScreenUpdating = False Application.CutCopyMode = False Application.DisplayAlerts = False On Error Resume Next Set x = Sheets("Лист1").Range("Данные") Debug.Print IsEmpty(x) x.copy Sheets("Лист2").Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Sheets("Лист1").Select Application.ScreenUpdating = False Application.CutCopyMode = False Application.DisplayAlerts = False End Sub
Всем доброго дня! Xpert, а Вам обязательно использовать второй лист и именованный диапазон? Попробуйте такой вариант: [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [c1]) Is Nothing Then Dim arr, li&, lmp#, rng As Range Set rng = Intersect([a1].EntireColumn, ActiveSheet.UsedRange) With Application .Calculation = xlCalculationManual .ScreenUpdating = False: .EnableEvents = False
arr = rng.Value .Undo: lmp = [c1]: .Undo
For li = 1 To UBound(arr) If Not IsEmpty(arr(li, 1)) Then arr(li, 1) = arr(li, 1) / (1 + lmp) * (1 + [c1]) Next li
rng.Value = arr
.Calculation = xlCalculationAutomatic .ScreenUpdating = True: .EnableEvents = True End With End If
End Sub
[/vba]
Всем доброго дня! Xpert, а Вам обязательно использовать второй лист и именованный диапазон? Попробуйте такой вариант: [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [c1]) Is Nothing Then Dim arr, li&, lmp#, rng As Range Set rng = Intersect([a1].EntireColumn, ActiveSheet.UsedRange) With Application .Calculation = xlCalculationManual .ScreenUpdating = False: .EnableEvents = False
arr = rng.Value .Undo: lmp = [c1]: .Undo
For li = 1 To UBound(arr) If Not IsEmpty(arr(li, 1)) Then arr(li, 1) = arr(li, 1) / (1 + lmp) * (1 + [c1]) Next li
rng.Value = arr
.Calculation = xlCalculationAutomatic .ScreenUpdating = True: .EnableEvents = True End With End If
Dim arr, li&, lmp#, rng As Range Set rng = Intersect([a1].EntireColumn, ActiveSheet.UsedRange)
If Not Intersect(Target, [c1]) Is Nothing And Target.Count = 1 Then .Undo: lmp = [c1]: .Undo arr = rng.Value For li = 1 To UBound(arr) If Not IsEmpty(arr(li, 1)) And IsNumeric(arr(li, 1)) Then arr(li, 1) = arr(li, 1) / (1 + lmp) * (1 + [c1]) Next li rng.Value = arr End If
If Not Intersect(Target, rng) Is Nothing Then If Not IsEmpty(Target) Then Target.Value = Evaluate(Target.Address & "*" & Replace(CStr(1 + [c1]), ",", ".")) End If
.Calculation = xlCalculationAutomatic .ScreenUpdating = True: .EnableEvents = True End With
Dim arr, li&, lmp#, rng As Range Set rng = Intersect([a1].EntireColumn, ActiveSheet.UsedRange)
If Not Intersect(Target, [c1]) Is Nothing And Target.Count = 1 Then .Undo: lmp = [c1]: .Undo arr = rng.Value For li = 1 To UBound(arr) If Not IsEmpty(arr(li, 1)) And IsNumeric(arr(li, 1)) Then arr(li, 1) = arr(li, 1) / (1 + lmp) * (1 + [c1]) Next li rng.Value = arr End If
If Not Intersect(Target, rng) Is Nothing Then If Not IsEmpty(Target) Then Target.Value = Evaluate(Target.Address & "*" & Replace(CStr(1 + [c1]), ",", ".")) End If
.Calculation = xlCalculationAutomatic .ScreenUpdating = True: .EnableEvents = True End With
Господа! Прилагаю свой файл. Ещё загвоздка в том, что при выставлении 0% в ячейке C1, значения в столбце А на листе 1 не возвращаются к первоначальным.
Господа! Прилагаю свой файл. Ещё загвоздка в том, что при выставлении 0% в ячейке C1, значения в столбце А на листе 1 не возвращаются к первоначальным.Xpert
If Not Intersect(Target, [c1]) Is Nothing And Target.Count = 1 Then Dim arr, li&, lmp# .Undo: lmp = [c1]: .Undo arr = rng.Value For li = 1 To UBound(arr) If Not IsEmpty(arr(li, 1)) And IsNumeric(arr(li, 1)) Then arr(li, 1) = arr(li, 1) / (1 + lmp) * (1 + [c1]) Next li rng.Value = arr End If
If Not Intersect(Target, rng) Is Nothing Then If Not IsEmpty(Target) Then Target.Value = Evaluate(Target.Address & "*" & Replace(CStr(1 + [c1]), ",", ".")) End If
.Calculation = xlCalculationAutomatic .ScreenUpdating = True: .EnableEvents = True End With
If Not Intersect(Target, [c1]) Is Nothing And Target.Count = 1 Then Dim arr, li&, lmp# .Undo: lmp = [c1]: .Undo arr = rng.Value For li = 1 To UBound(arr) If Not IsEmpty(arr(li, 1)) And IsNumeric(arr(li, 1)) Then arr(li, 1) = arr(li, 1) / (1 + lmp) * (1 + [c1]) Next li rng.Value = arr End If
If Not Intersect(Target, rng) Is Nothing Then If Not IsEmpty(Target) Then Target.Value = Evaluate(Target.Address & "*" & Replace(CStr(1 + [c1]), ",", ".")) End If
.Calculation = xlCalculationAutomatic .ScreenUpdating = True: .EnableEvents = True End With
Приветствую всех участников! Подправил данный макрос для использования в рамках "умной таблицы". Вроде всё работает, но есть одно НО. При вставке строк получается такая картина
формулы в Столбце 5 не копируются в новые строки. Появляются нули за пределами границ таблицы...
При удалении - такая: Опять нули.
Помогите это исправить.
ПРимер прилагаю.
Приветствую всех участников! Подправил данный макрос для использования в рамках "умной таблицы". Вроде всё работает, но есть одно НО. При вставке строк получается такая картина
формулы в Столбце 5 не копируются в новые строки. Появляются нули за пределами границ таблицы...
- Прочитайте Правила форума - Создайте новую тему согласно п.5q Правил форума. Причем здесь умножение ячеек на число? картинки не на Радикал нужно класть, а сюда, также, как и Excel файлы
- Прочитайте Правила форума - Создайте новую тему согласно п.5q Правил форума. Причем здесь умножение ячеек на число? картинки не на Радикал нужно класть, а сюда, также, как и Excel файлы_Boroda_
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
