Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Подкорректировать диапазон ячеек в исполняемом макросе - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Подкорректировать диапазон ячеек в исполняемом макросе
Xpert Дата: Вторник, 20.10.2020, 13:52 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 117
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Здравствуйте, уважаемые форумчане!
Прошу Вашей помощи.
Макрос
[vba]
Код

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim rng As Range
    Set rng = [Диапазон]: If rng Is Nothing Then Exit Sub
    
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False: .EnableEvents = False
        
        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
    
End Sub
[/vba]

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

Прошу помочь советом!
К сообщению приложен файл: 6698536.xlsm (104.2 Kb) · 6227196.png (83.3 Kb)


Сообщение отредактировал Xpert - Вторник, 20.10.2020, 13:53
 
Ответить
СообщениеЗдравствуйте, уважаемые форумчане!
Прошу Вашей помощи.
Макрос
[vba]
Код

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim rng As Range
    Set rng = [Диапазон]: If rng Is Nothing Then Exit Sub
    
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False: .EnableEvents = False
        
        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
    
End Sub
[/vba]

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

Прошу помочь советом!

Автор - Xpert
Дата добавления - 20.10.2020 в 13:52
RAN Дата: Вторник, 20.10.2020, 17:01 | Сообщение № 2
Группа: Друзья
Ранг: Экселист
Сообщений: 5660
Репутация: 1163 ±
Замечаний: 0% ±

2010
[vba]
Код
arr = Rng.Value
If Not IsArray(arr) Then
    ReDim arr(1 To 1, 1 To 1)
    arr(1, 1) = Rng.Value
End If
[/vba]


Быть или не быть, вот в чем загвоздка!
 
Ответить
Сообщение[vba]
Код
arr = Rng.Value
If Not IsArray(arr) Then
    ReDim arr(1 To 1, 1 To 1)
    arr(1, 1) = Rng.Value
End If
[/vba]

Автор - RAN
Дата добавления - 20.10.2020 в 17:01
Xpert Дата: Среда, 21.10.2020, 09:48 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 117
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
RAN, Огромное спасибо!
 
Ответить
СообщениеRAN, Огромное спасибо!

Автор - Xpert
Дата добавления - 21.10.2020 в 09:48
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!