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

Вход

Регистрация

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

 

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

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Посчитать количество изменений в диапазоне ячеек (Макросы/Sub)
Посчитать количество изменений в диапазоне ячеек
Anis625 Дата: Воскресенье, 10.03.2019, 09:48 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 245
Репутация: 2 ±
Замечаний: 0% ±

Excel 2013
Добрый день, участникам форума!

В поисках решения своей задачки в интернете нашел две статьи почти подходящие под мой вопрос: "Посчитать количество изменений в диапазоне ячеек и вывести результат в аналогичный диапазон рядом". Один из вариантов решения задачки с одной ячейкой написал _Boroda_, в данном форуме тут

Попробовал адаптировать под свою задачку с диапазоном ячеек:

[vba]
Код
Dim n_

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, [A1:R35]) Is Nothing Then
    n_ = [A1:R35]
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [A1:R35]) Is Nothing Then
    If [A1:R35] <> n_ Then [T1:AK35] = [T1:AK35] + 1
End If
End Sub
[/vba]

При попытке внести изменения в заданный диапазон макрос ругается на
[vba]
Код
If [A1:R35] <> n_ Then
[/vba]

Получается прямым изменением диапазона макрос не работает?

P.S.
Серым цветом выделил изменяемые диапазоны, но можно сделать подсчет изменений всего диапазона и зеркально подсчитать количество изменений в диапазоне справа.

Строки могут добавляться.
К сообщению приложен файл: 3101900.xlsb(28.0 Kb)
 
Ответить
СообщениеДобрый день, участникам форума!

В поисках решения своей задачки в интернете нашел две статьи почти подходящие под мой вопрос: "Посчитать количество изменений в диапазоне ячеек и вывести результат в аналогичный диапазон рядом". Один из вариантов решения задачки с одной ячейкой написал _Boroda_, в данном форуме тут

Попробовал адаптировать под свою задачку с диапазоном ячеек:

[vba]
Код
Dim n_

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, [A1:R35]) Is Nothing Then
    n_ = [A1:R35]
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [A1:R35]) Is Nothing Then
    If [A1:R35] <> n_ Then [T1:AK35] = [T1:AK35] + 1
End If
End Sub
[/vba]

При попытке внести изменения в заданный диапазон макрос ругается на
[vba]
Код
If [A1:R35] <> n_ Then
[/vba]

Получается прямым изменением диапазона макрос не работает?

P.S.
Серым цветом выделил изменяемые диапазоны, но можно сделать подсчет изменений всего диапазона и зеркально подсчитать количество изменений в диапазоне справа.

Строки могут добавляться.

Автор - Anis625
Дата добавления - 10.03.2019 в 09:48
krosav4ig Дата: Понедельник, 11.03.2019, 15:24 | Сообщение № 2
Группа: Друзья
Ранг: Старожил
Сообщений: 1984
Репутация: 840 ±
Замечаний: 0% ±

Excel 2007,2010,2013
Здравствуйте [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim dic As Object, arr1 As Variant, i&, j&, ar As Range, ac As Range
    If Not Intersect(Target, [A1:R35]) Is Nothing Then
        With Application
            Set ac = .ActiveCell
            Set dic = CreateObject("scripting.dictionary")
            .ScreenUpdating = 0
            .EnableEvents = 0
            .Undo 'отмена изменения
            With Target
                For Each ar In .Areas
                    With ar
                        If .Count = 1 Then
                            ReDim arr1(1 To 1, 1 To 1)
                            arr1(1, 1) = .Value
                            dic(.Address) = arr1
                        Else
                            dic(.Address) = .Value
                        End If
                    End With
                Next
            End With
            .Undo 'отмена отмены изменения
            With Target
                For Each ar In .Areas
                    For i = 1 To ar.Rows.Count
                        For j = 1 To ar.Columns.Count
                            If dic(ar.Address)(i, j) <> ar.Cells(i, j) Then
                    ar.Cells(i, j).Offset(, 19) = 1
                            End If
                Next j, i, ar
            End With
            ac.Activate
            .ScreenUpdating = 1
            .EnableEvents = 1
        End With
        Set dic = Nothing
    End If
End Sub
[/vba]


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460

Сообщение отредактировал krosav4ig - Понедельник, 11.03.2019, 15:26
 
Ответить
СообщениеЗдравствуйте [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim dic As Object, arr1 As Variant, i&, j&, ar As Range, ac As Range
    If Not Intersect(Target, [A1:R35]) Is Nothing Then
        With Application
            Set ac = .ActiveCell
            Set dic = CreateObject("scripting.dictionary")
            .ScreenUpdating = 0
            .EnableEvents = 0
            .Undo 'отмена изменения
            With Target
                For Each ar In .Areas
                    With ar
                        If .Count = 1 Then
                            ReDim arr1(1 To 1, 1 To 1)
                            arr1(1, 1) = .Value
                            dic(.Address) = arr1
                        Else
                            dic(.Address) = .Value
                        End If
                    End With
                Next
            End With
            .Undo 'отмена отмены изменения
            With Target
                For Each ar In .Areas
                    For i = 1 To ar.Rows.Count
                        For j = 1 To ar.Columns.Count
                            If dic(ar.Address)(i, j) <> ar.Cells(i, j) Then
                    ar.Cells(i, j).Offset(, 19) = 1
                            End If
                Next j, i, ar
            End With
            ac.Activate
            .ScreenUpdating = 1
            .EnableEvents = 1
        End With
        Set dic = Nothing
    End If
End Sub
[/vba]

Автор - krosav4ig
Дата добавления - 11.03.2019 в 15:24
Anis625 Дата: Понедельник, 11.03.2019, 16:15 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 245
Репутация: 2 ±
Замечаний: 0% ±

Excel 2013
krosav4ig,
крууууууууууто. Почти срабатывает как надо. Только повторное изменение того же значения не считает. То есть счет останавливается на 1 =(
 
Ответить
Сообщениеkrosav4ig,
крууууууууууто. Почти срабатывает как надо. Только повторное изменение того же значения не считает. То есть счет останавливается на 1 =(

Автор - Anis625
Дата добавления - 11.03.2019 в 16:15
krosav4ig Дата: Понедельник, 11.03.2019, 16:26 | Сообщение № 4
Группа: Друзья
Ранг: Старожил
Сообщений: 1984
Репутация: 840 ±
Замечаний: 0% ±

Excel 2007,2010,2013
Так надо что ли?
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim dic As Object, arr1 As Variant, i&, j&, ar As Range, ac As Range
    If Not Intersect(Target, [A1:R35]) Is Nothing Then
        With Application
            Set ac = .ActiveCell
            Set dic = CreateObject("scripting.dictionary")
            .ScreenUpdating = 0
            .EnableEvents = 0
            .Undo 'отмена изменения
            With Target
                For Each ar In .Areas
                    i = i + 1
                    With ar
                        If .Count = 1 Then
                            ReDim arr1(1 To 1, 1 To 1)
                            arr1(1, 1) = .Value
                            dic(.Address) = arr1
                        Else
                            dic(.Address) = .Value
                        End If
                    End With
                Next
            End With
            .Undo 'отмена отмены изменения
            With Target
                For Each ar In .Areas
                    For i = 1 To ar.Rows.Count
                        For j = 1 To ar.Columns.Count
                            If dic(ar.Address)(i, j) <> ar.Cells(i, j) Then
                    With ar.Cells(i, j).Offset(, 19)
                    .Value = IIf(IsNumeric(.Value), .Value, 0) + 1
                    End With
                            End If
                Next j, i, ar
            End With
            ac.Activate
            .ScreenUpdating = 1
            .EnableEvents = 1
        End With
        Set dic = Nothing
    End If
End Sub
[/vba]


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460
 
Ответить
СообщениеТак надо что ли?
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim dic As Object, arr1 As Variant, i&, j&, ar As Range, ac As Range
    If Not Intersect(Target, [A1:R35]) Is Nothing Then
        With Application
            Set ac = .ActiveCell
            Set dic = CreateObject("scripting.dictionary")
            .ScreenUpdating = 0
            .EnableEvents = 0
            .Undo 'отмена изменения
            With Target
                For Each ar In .Areas
                    i = i + 1
                    With ar
                        If .Count = 1 Then
                            ReDim arr1(1 To 1, 1 To 1)
                            arr1(1, 1) = .Value
                            dic(.Address) = arr1
                        Else
                            dic(.Address) = .Value
                        End If
                    End With
                Next
            End With
            .Undo 'отмена отмены изменения
            With Target
                For Each ar In .Areas
                    For i = 1 To ar.Rows.Count
                        For j = 1 To ar.Columns.Count
                            If dic(ar.Address)(i, j) <> ar.Cells(i, j) Then
                    With ar.Cells(i, j).Offset(, 19)
                    .Value = IIf(IsNumeric(.Value), .Value, 0) + 1
                    End With
                            End If
                Next j, i, ar
            End With
            ac.Activate
            .ScreenUpdating = 1
            .EnableEvents = 1
        End With
        Set dic = Nothing
    End If
End Sub
[/vba]

Автор - krosav4ig
Дата добавления - 11.03.2019 в 16:26
Anis625 Дата: Понедельник, 11.03.2019, 16:43 | Сообщение № 5
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 245
Репутация: 2 ±
Замечаний: 0% ±

Excel 2013
krosav4ig,

Бингоооооооо, то что нужно =) Благодарю Вас. Капец дикое желание научиться самому писать макросы как все тут знатоки VBA но не понимаю с чего начать.
 
Ответить
Сообщениеkrosav4ig,

Бингоооооооо, то что нужно =) Благодарю Вас. Капец дикое желание научиться самому писать макросы как все тут знатоки VBA но не понимаю с чего начать.

Автор - Anis625
Дата добавления - 11.03.2019 в 16:43
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Посчитать количество изменений в диапазоне ячеек (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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