Новости:

К первому сообщению темы должен быть прикреплен файл примера в формате xls*.
Приложив пример, Вы избавите себя и других от вопросов типа "А какой критерий?", "А куда выводить результат?", "А сколько строк?" и все тех же просьб выложить файл. Рисовать за Вас Ваши же таблички с заданиями, а затем и решение к ним, никто желанием не горит. Да и, как показывает практика, в большинстве случаев без файла решения не найти.

Главное меню

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

Автор Michael Holbrook, 20.05.2014, 12:49

« назад - далее »

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


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

#3
Цитата: cheshiki1 от 20.05.2014, 13:57
1.Range("D5:E5,J5").ClearContents
Спасибо!

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



cheshiki1

тогда вам нужно код вешать на событие пересчета Private Sub Worksheet_Calculate(). здесь я пас, моих знаний не хватает.

Michael Holbrook

Цитата: cheshiki1 от 20.05.2014, 16:28
тогда вам нужно код вешать на событие пересчета Private Sub Worksheet_Calculate(). здесь я пас, моих знаний не хватает.
Окей. В любом случае спасибо вам за помощь!

Michael Holbrook

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

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

Цитата: cheshiki1 от 21.05.2014, 11:11
ЦитироватьТ.е. грубо говоря вот так должно быть:
Так оно и есть. Только здесь одно но где то нужно записывать текущее значение ячейки чтобы после срабатывания процедуры было с чем сравнивать. ([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

#13
Доброго дня!
Причину не сработки сценария, Вам верно указал, уважаемый 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

#14
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

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

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