Ну да. Только ради "прикола" сделал две переменные "М" - меньшее и "В"- большее. И только сейчас врубился - в конце строки IF.... получилось В) а сочетание "В)" это вот такой смайлик . Вот и вся гениальность. Кто бы мог подумать! Заменил В на Z. Надеюсь сочетание Z) не смайлик. [vba]
Код
Sub Макрос_2() Dim x&, j&, M@, Z@ M = -1.9 Z = 1.9 For x = 1 To 20 For j = 8 To 57 If Cells(j, "U") <> "" And (Cells(j, "W") < M Or Cells(j, "W") > Z) Then Cells(j, "W").Value = Cells(j, "W").Value Cells(j, "W").Interior.ColorIndex = 36 Cells(j, "X") = "Отбраковывается" Cells(j, "X").Interior.ColorIndex = 36 Intersect(Rows(j), Range("U:U,AL:AM,AS:as")).ClearContents End If Next j If Range("AS60") <= 1.5 And Range("AU61") >= 0.7 And (Range("AH63") >= 6 And Range("AH63") <= 15) Then MsgBox "Условие выполнено, процедура закончена" Exit Sub Else If MsgBox("Условие не выполнено. Продолжить?", vbYesNo) = 6 Then M = M + 0.1 Z = Z - 0.1 Cells(3, "V") = M Cells(3, "W") = Z Else Cells(3, "V") = "" Cells(3, "W") = "" Exit Sub End If End If Next x End Sub
Ну да. Только ради "прикола" сделал две переменные "М" - меньшее и "В"- большее. И только сейчас врубился - в конце строки IF.... получилось В) а сочетание "В)" это вот такой смайлик . Вот и вся гениальность. Кто бы мог подумать! Заменил В на Z. Надеюсь сочетание Z) не смайлик. [vba]
Код
Sub Макрос_2() Dim x&, j&, M@, Z@ M = -1.9 Z = 1.9 For x = 1 To 20 For j = 8 To 57 If Cells(j, "U") <> "" And (Cells(j, "W") < M Or Cells(j, "W") > Z) Then Cells(j, "W").Value = Cells(j, "W").Value Cells(j, "W").Interior.ColorIndex = 36 Cells(j, "X") = "Отбраковывается" Cells(j, "X").Interior.ColorIndex = 36 Intersect(Rows(j), Range("U:U,AL:AM,AS:as")).ClearContents End If Next j If Range("AS60") <= 1.5 And Range("AU61") >= 0.7 And (Range("AH63") >= 6 And Range("AH63") <= 15) Then MsgBox "Условие выполнено, процедура закончена" Exit Sub Else If MsgBox("Условие не выполнено. Продолжить?", vbYesNo) = 6 Then M = M + 0.1 Z = Z - 0.1 Cells(3, "V") = M Cells(3, "W") = Z Else Cells(3, "V") = "" Cells(3, "W") = "" Exit Sub End If End If Next x End Sub
Wasilich, Доброе утро!!! А также всем. Пожалуйста посмотрите, что я не так сделал почему макросы не так работают Когда я перенес макрос от ТЕЗКИ в данный файл и при его активации мне выходит вот это [img][/img] Не понимаю вообще почему ((((( что случилось я лишь изменил ячейки D на E во всем макросе и ни чего более. Может я его не туда перенес [img][/img] Сам макрос от ТЕЗКИ [vba]
Код
Sub tt() Dim e_ As Range 'e - массив ячеек Application.ScreenUpdating = 0 'отключаем обновление экрана r1_ = Range("E" & Rows.Count).End(xlUp).Row 'последняя заполненная строка в столбце E r0_ = 9 'первая строка n_ = 10 'кол-во столбцов For i = r0_ To r1_ 'цикл по строкам Set e_ = Range("E" & i).Resize(, n_) 'говорим, что e будет n ячеек вправо от столбца E i-ой строки x1_ = 0 x2_ = 0 For j = 1 To n_ ' цикл от одного до n (больше, чем n ячеек удалить просто не получится) 'блок 1 If x1_ = 0 Then 'если x1_=0, то mx_ = WorksheetFunction.Max(e_) 'ищем максимум по e mn_ = WorksheetFunction.Min(e_) 'ищем минимум по e On Error Resume Next 'пропускаем ошибку (на случай, если все значения пусты или =0) av_ = WorksheetFunction.Average(e_) 'ищем среднее по d e1_ = Err.Number ' присваиваем e значение ошибки (для деления на 0 ошибка 1004, иначе - false) On Error GoTo 0 'убираем пропуск ошибок z1_ = (mx_ - av_ <= 4) + e1_ = 0 'mx_ - av_ <= 4 даст true или false и плюс e 'даст 0 тогда, когда уже не нужно удалять лишнее If z1_ Then ' если z1 не 0, то n1_ = WorksheetFunction.Match(mx_, e_, 0) 'ПОИСКПОЗом ищем позицию максимума в e Range("E" & i).Offset(, n1_ - 1).ClearContents 'стираем ее Else 'если z1 = 0, то x1_ = 1 'присваиваем х1 единицу If x2_ Then 'если при этом и х2 тоже единица, то Exit For 'выход из цикла End If End If End If 'блок 2 аналогично блоку 1 If x2_ = 0 Then mn_ = WorksheetFunction.Min(e_) On Error Resume Next av_ = WorksheetFunction.Average(e_) e2_ = Err.Number On Error GoTo 0 z2_ = (av_ - mn_ <= 4) + e2_ = 0 If z2_ Then n2_ = WorksheetFunction.Match(mn_, e_, 0) Range("E" & i).Offset(, n2_ - 1).ClearContents Else x2_ = 1 If x1_ Then Exit For End If End If End If Next j Next i End Sub
[/vba] Пожалуйста подскажите мне очень нужен данный файл уже в работе ((((( СПАСИТЕ
Wasilich, Доброе утро!!! А также всем. Пожалуйста посмотрите, что я не так сделал почему макросы не так работают Когда я перенес макрос от ТЕЗКИ в данный файл и при его активации мне выходит вот это [img][/img] Не понимаю вообще почему ((((( что случилось я лишь изменил ячейки D на E во всем макросе и ни чего более. Может я его не туда перенес [img][/img] Сам макрос от ТЕЗКИ [vba]
Код
Sub tt() Dim e_ As Range 'e - массив ячеек Application.ScreenUpdating = 0 'отключаем обновление экрана r1_ = Range("E" & Rows.Count).End(xlUp).Row 'последняя заполненная строка в столбце E r0_ = 9 'первая строка n_ = 10 'кол-во столбцов For i = r0_ To r1_ 'цикл по строкам Set e_ = Range("E" & i).Resize(, n_) 'говорим, что e будет n ячеек вправо от столбца E i-ой строки x1_ = 0 x2_ = 0 For j = 1 To n_ ' цикл от одного до n (больше, чем n ячеек удалить просто не получится) 'блок 1 If x1_ = 0 Then 'если x1_=0, то mx_ = WorksheetFunction.Max(e_) 'ищем максимум по e mn_ = WorksheetFunction.Min(e_) 'ищем минимум по e On Error Resume Next 'пропускаем ошибку (на случай, если все значения пусты или =0) av_ = WorksheetFunction.Average(e_) 'ищем среднее по d e1_ = Err.Number ' присваиваем e значение ошибки (для деления на 0 ошибка 1004, иначе - false) On Error GoTo 0 'убираем пропуск ошибок z1_ = (mx_ - av_ <= 4) + e1_ = 0 'mx_ - av_ <= 4 даст true или false и плюс e 'даст 0 тогда, когда уже не нужно удалять лишнее If z1_ Then ' если z1 не 0, то n1_ = WorksheetFunction.Match(mx_, e_, 0) 'ПОИСКПОЗом ищем позицию максимума в e Range("E" & i).Offset(, n1_ - 1).ClearContents 'стираем ее Else 'если z1 = 0, то x1_ = 1 'присваиваем х1 единицу If x2_ Then 'если при этом и х2 тоже единица, то Exit For 'выход из цикла End If End If End If 'блок 2 аналогично блоку 1 If x2_ = 0 Then mn_ = WorksheetFunction.Min(e_) On Error Resume Next av_ = WorksheetFunction.Average(e_) e2_ = Err.Number On Error GoTo 0 z2_ = (av_ - mn_ <= 4) + e2_ = 0 If z2_ Then n2_ = WorksheetFunction.Match(mn_, e_, 0) Range("E" & i).Offset(, n2_ - 1).ClearContents Else x2_ = 1 If x1_ Then Exit For End If End If End If Next j Next i End Sub
[/vba] Пожалуйста подскажите мне очень нужен данный файл уже в работе ((((( СПАСИТЕlebensvoll