Корректировка кода VBA (очистка ячеек по условию)

[Michael Holbrook]

Всем привет!
Необходимо откорректировать код.

Есть код...

Код Выделить Развернуть

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range: Set rng = [C5] 'диапазон вашей таблицы
    If Not Intersect(rng, Target) Is Nothing Then Макрос2
    With ActiveWorkbook.Worksheets("Лист2").AutoFilter.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("F5:F" & Range("D" & Rows.Count).End(xlUp).Row), Order:=xlAscending
        .SortFields.Add Key:=Range("G5:G" & Range("E" & Rows.Count).End(xlUp).Row), Order:=xlAscending
        .Apply
        End With
End Sub
   


...в котором интересует вот эта часть.

Код Выделить Развернуть

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range: Set rng = [C5] 'диапазон вашей таблицы
    If Not Intersect(rng, Target) Is Nothing Then Макрос2


Суть состоит в том, что если в ячейке C5 меняется значение, то выполняется очистка данных ячейки D5 в виде такого кода.

Код Выделить Развернуть

Sub Макрос2()
Range("D5").Select
Selection.ClearContents
End Sub



Вопрос 1: будучи неграмотным в VBA не знаю, как в этом коде:

Код Выделить Развернуть

Sub Макрос2()
Range("D5").Select
Selection.ClearContents
End Sub



...сделать так, чтобы производилась очистка данных еще в ячейках E5 и J5.


Вопрос 2: как сделать, чтобы действия очистки производились и на остальные ячейки в столбце C. Т.е. если в C6 меняется значение - очищаем ячейки D6, E6 и J6.  И.т.д.

[cheshiki1]

1.

Код Выделить Развернуть

Range("D5:E5,J5").ClearContents

[cheshiki1]

1. макрос будет срабатывать при изменении в диапазоне "C5:C10"

Код Выделить Развернуть

If Not Intersect(Target, Range("C5:C10")) Is Nothing Then R = Target.Row: макрос2
2.

Код Выделить Развернуть

Public R&
Sub макрос2()
Range("D" & R & ":E" & R & ",J" & R).ClearContents
End Sub

[Michael Holbrook]

1.

Код Выделить Развернуть

Range("D5:E5,J5").ClearContents

Спасибо!

Все работает, ячейки очищаются. Одно но, я не уточнил. Кажется, что очистка происходит, когда в ячейки столбца C вводятся новые данные, но у меня там формулы, которые извлекают данные из другого места. Поэтому необходимо, чтобы он производил очистку не при вводе и впоследствии изменении значения в ячейки, а просто при изменении

[cheshiki1]

тогда вам нужно код вешать на событие пересчета

Код Выделить Развернуть

Private Sub Worksheet_Calculate(). здесь я пас, моих знаний не хватает.

[Michael Holbrook]

тогда вам нужно код вешать на событие пересчета

Код Выделить Развернуть

Private Sub Worksheet_Calculate(). здесь я пас, моих знаний не хватает.

Окей. В любом случае спасибо вам за помощь!

[Michael Holbrook]

Кстати, вот нашел такой вариант.

Код Выделить Развернуть

Private Sub Worksheet_Calculate()
If [a1] <> test Then MsgBox "Изменилось!!!": test = [a1]
End Sub
При изменении значения ячейки a1 - появляется окошко с текстом.

Не подскажете, как мне заменить

Код Выделить Развернуть

Then MsgBox "Изменилось!!!": test = [a1]

на выполнение моего "макроса2"?


Т.е. грубо говоря вот так должно быть:

Код Выделить Развернуть

Private Sub Worksheet_Calculate()
If [C5] <> test Then макрос2
End Sub


а макрос 2 выглядит так:

Код Выделить Развернуть

Public R&
Sub макрос2()
Range("D" & R & ":E" & R & ",J" & R).ClearContents
End Sub


[cheshiki1]

Т.е. грубо говоря вот так должно быть:

Так оно и есть. Только здесь одно но где то нужно записывать текущее значение ячейки чтобы после срабатывания процедуры было с чем сравнивать. ([a1] <> test, где test это ячейка где сохранено предыдущее значение.) По моему так но могу и ошибаться.

[Michael Holbrook]

Т.е. грубо говоря вот так должно быть:

Так оно и есть. Только здесь одно но где то нужно записывать текущее значение ячейки чтобы после срабатывания процедуры было с чем сравнивать. ([a1] <> test, где test это ячейка где сохранено предыдущее значение.) По моему так но могу и ошибаться.

Видимо вот это.

Код в рабочей книге:

Код Выделить Развернуть

Option Explicit

Private Sub Workbook_Open()
test = Лист.[a1]
End Sub

и вот еще код в дополнительном модуле:

Код Выделить Развернуть

Option Explicit

Public test


[cheshiki1]

Видимо вот это.

да.
вот нашел примеры для одной ячейки.

Код Выделить Развернуть

вариант 1
Private Sub Worksheet_Change(ByVal Target As Range)
Application.DisplayAlerts = False
    If Not (Intersect(Target, Union(Me.Range("A1"), Me.Range("A1").Precedents)) Is Nothing) Then
        MsgBox "A1 изменена"
    End If
Application.DisplayAlerts = True
End Sub

вариант 2
Private Sub Worksheet_Calculate()
Static v As Variant
    If Me.Range("A1").Value <> v Then
        MsgBox "A1 изменена"
        v = Me.Range("A1").Value
    End If
End Sub

[Michael Holbrook]

Вот этот вариант у меня работает.

Код листа

Код Выделить Развернуть

Private Sub Worksheet_Calculate()
If [C5] <> test Then MsgBox "Изменилось!!!": test = [C5]
End Sub


Код книги

Код Выделить Развернуть

Option Explicit
Private Sub Workbook_Open()
test = Лист2.[C5]
End Sub

Модуль

Код Выделить Развернуть

Option Explicit

Public test

Все отлично, если значение ячейки меняется по расчету формулы - выскакивает сообщение.

Единственное что, мне вместо мэссэджбокса надо запускать свой макрос 2

Код Выделить Развернуть

Public R&
Sub макрос2()
Range("D" & R & ":E" & R & ",J" & R).ClearContents
End Sub


Но как вписать корректно, не пойму. Так не работает.

Код Выделить Развернуть

Private Sub Worksheet_Calculate()
If [C5] <> test Then макрос2
End Sub

[cheshiki1]

Так не работает.

По идее должно работать. единственное вы пропустили ": test = [C5]" а оно обязательно иначе значение test не будет меняться.
последний вариант файла приложите.
П.С. у вас R не найдено. т.к. проверяется одна ячейка то "Range("D" & R & ":E" & R & ",J" & R).ClearContents " замените на
"Range("D5:E5,J5").ClearContents"

[Michael Holbrook]

cheshiki1, спасибо Вам за то, что уделяете время!

Скидываю 2 варианта.

Сначала тот работающий, чтобы понятнее было, в чем вообще моя задача состоит. Есть два файла - "Инвентаризационная" и "База данных с группами123456789". В файле "База данных с группами123456789" ячейка C5 извлекает код из ячейки B17 в файле "Инвентаризационная". Задача: если в ячейке C5 в первом файле меняется код - очищаются ячейки D5, E5 и J5. Далее у меня если D5, E5 и J5 становятся пустыми, то по коду моей сортировки они опускаются вниз.

Для наглядности того, что этот вариант работает. Меняем в ячейке B17 в файле "Инвентаризационная" номенклатурный код и видим, что файле "База данных с группами123456789" в ячейке C5 обновился код, но не очистились D5, E5 и J5. А вот если вручную сменить в ячейке C5 значение - D5, E5 и J5 очищаются и сортируются вниз.


А теперь второй пример со всеми замечаниями и обновлениями. Я вроде все учел. Опять же, меняем в ячейке B17 в файле "Инвентаризационная" код и видим, что файле "База данных с группами123456789" в ячейке C5 обновился код, но не очистились D5, E5 и J5. А вот теперь если вручную сменить в ячейке C5 значение - ячейки D5, E5 и J5 очищаются, но не сортируются вниз и эксель вообще полностью виснет

[GWolf]

Доброго дня!
Причину не сработки сценария, Вам верно указал, уважаемый cheshiki1: Значение старое, которое Вы заносите в test, нужно сохранять до того как Вы пересчитали ячейку С5! Иначе у Вас и текущее значение С5 и занесенное в test будут одинаковы!

К стати:

Код Выделить Развернуть

Private Sub Worksheet_Calculate()
    Dim test As String

    If [C5] <> test Then
        test = [C5]
        Range("D5:E5,J5").ClearContents
    End If
End Sub


вот так можно реализовать очистку в "теле" Worksheet_Calculate, тогда Макрос 2 не нужен.

P.S.
Набросал вариант, на скрепке.
На всякий случай, продублирую представленный в файле код:

Код Выделить Развернуть

Private Sub Worksheet_Calculate()
    If Cells(ActiveCell.Row - 1, 5).Value <> Cells(ActiveCell.Row - 1, 16).Value Then
        ySNo = MsgBox("Удалить значения в диапазоне и в ячейке?" & Chr(13) & "- Да / Нет.", vbQuestion + vbYesNo, "Запрос системы:")
        If ySNo = 6 Then '- Да (=6)
            Range(Cells(ActiveCell.Row - 1, 9), Cells(ActiveCell.Row - 1, 11)).ClearContents
            Cells(ActiveCell.Row - 1, 14).ClearContents
        Else '- Нет (=7)
            MsgBox "Вы выбрали довольно странный путь!" & Chr(13) & "- Прощайте!", vbInformation + vbOKOnly, "Сообщение системы:"
        End If
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Column = 3 Or Target.Column = 4 Then
        Cells(Target.Row, 16) = Cells(Target.Row, 5).Value
    End If
End Sub

[Michael Holbrook]

GWolf, здравствуйте! Спасибо за помощь!

Попробовал ваш код без моей сортировки и с сортировкой:

Код Выделить Развернуть

Private Sub Worksheet_Calculate()
    Dim test As String

    If [C5] <> test Then
        test = [C5]
        Range("D5:E5,J5").ClearContents
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range: Set rng = [C5:C3000] 'диапазон вашей таблицы
    If Not Intersect(Target, Range("C5:C3000")) Is Nothing Then R = Target.Row: макрос2
    With ActiveWorkbook.Worksheets("Лист2").AutoFilter.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("F5:F" & Range("D" & Rows.Count).End(xlUp).Row), Order:=xlAscending
        .SortFields.Add Key:=Range("G5:G" & Range("E" & Rows.Count).End(xlUp).Row), Order:=xlAscending
        .Apply
        End With
End Sub 


Куча ошибок продолжает мне выдавать. К примеру Out of stack space. Так же VBA выделяет эту часть кода:

Код Выделить Развернуть

If [C5] <> test Then

Архив прикрепил.

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