Посчитать количество изменений в диапазоне ячеек

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Посчитать количество изменений в диапазоне ячеек (Макросы/Sub)

Anis625

Дата: Воскресенье, 10.03.2019, 09:48 | Сообщение № 1

Группа: Заблокированные

Ранг: Ветеран

Сообщений: 674

Репутация: 31 ±

Замечаний: 20% ±

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)

Ответить

krosav4ig

Дата: Понедельник, 11.03.2019, 15:24 | Сообщение № 2

Группа: Друзья

Ранг: Старожил

Сообщений: 2347

Репутация: 997 ±

Замечаний: 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]

Здравствуйте [vba]

Код

[/vba]krosav4ig

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

Сообщение отредактировал krosav4ig - Понедельник, 11.03.2019, 15:26

Ответить

СообщениеЗдравствуйте [vba]

Код

[/vba]

Автор - krosav4ig
Дата добавления - 11.03.2019 в 15:24

Anis625

Дата: Понедельник, 11.03.2019, 16:15 | Сообщение № 3

Группа: Заблокированные

Ранг: Ветеран

Сообщений: 674

Репутация: 31 ±

Замечаний: 20% ±

Excel 2013

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

Ответить

krosav4ig

Дата: Понедельник, 11.03.2019, 16:26 | Сообщение № 4

Группа: Друзья

Ранг: Старожил

Сообщений: 2347

Репутация: 997 ±

Замечаний: 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]

Так надо что ли?
[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

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

Группа: Заблокированные

Ранг: Ветеран

Сообщений: 674

Репутация: 31 ±

Замечаний: 20% ±

Excel 2013

krosav4ig,

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

Ответить

Посчитать количество изменений в диапазоне ячеек (Макросы/Sub)

Страница 1 из 1
1