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

Вход

Регистрация

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

 

= Мир MS Excel/Теория вероятности Определить теоретич значения для удаления - Страница 5 - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 5 из 5«12345
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Теория вероятности Определить теоретич значения для удаления (Макросы/Sub)
Теория вероятности Определить теоретич значения для удаления
Wasilich Дата: Вторник, 05.04.2016, 18:53 | Сообщение № 81
Группа: Друзья
Ранг: Ветеран
Сообщений: 855
Репутация: 220 ±
Замечаний: 0% ±

2003
уважаемые ГЕНИИ прикалываются я так понимаю
Ну да. :D
Только ради "прикола" сделал две переменные "М" - меньшее и "В"- большее. И только сейчас врубился - в конце строки IF.... получилось В) а сочетание "В)" это вот такой смайлик B) . Вот и вся гениальность. Кто бы мог подумать! %) :D
Заменил В на 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
[/vba]


Сообщение отредактировал Wasilich - Вторник, 05.04.2016, 19:09
 
Ответить
Сообщение
уважаемые ГЕНИИ прикалываются я так понимаю
Ну да. :D
Только ради "прикола" сделал две переменные "М" - меньшее и "В"- большее. И только сейчас врубился - в конце строки IF.... получилось В) а сочетание "В)" это вот такой смайлик B) . Вот и вся гениальность. Кто бы мог подумать! %) :D
Заменил В на 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
[/vba]

Автор - Wasilich
Дата добавления - 05.04.2016 в 18:53
lebensvoll Дата: Четверг, 07.04.2016, 10:30 | Сообщение № 82
Группа: Проверенные
Ранг: Ветеран
Сообщений: 645
Репутация: 2 ±
Замечаний: 60% ±

Excel 2010
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]
Пожалуйста подскажите мне очень нужен данный файл уже в работе ((((( СПАСИТЕ
К сообщению приложен файл: 9975582.xlsm(80Kb)


Кто бы ты ни был, мир в твоих руках
 
Ответить
Сообщение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
Дата добавления - 07.04.2016 в 10:30
_Boroda_ Дата: Четверг, 07.04.2016, 10:52 | Сообщение № 83
Группа: Модераторы
Ранг: Экселист
Сообщений: 9346
Репутация: 3922 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
У Вас на первой кнопке была ссылка на книгу ..._2 макрос tt.
Переделал ее на тот же макрос из этой книги.
К сообщению приложен файл: 8888888.xlsm(76Kb)


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеУ Вас на первой кнопке была ссылка на книгу ..._2 макрос tt.
Переделал ее на тот же макрос из этой книги.

Автор - _Boroda_
Дата добавления - 07.04.2016 в 10:52
lebensvoll Дата: Четверг, 07.04.2016, 11:01 | Сообщение № 84
Группа: Проверенные
Ранг: Ветеран
Сообщений: 645
Репутация: 2 ±
Замечаний: 60% ±

Excel 2010
_Boroda_, А точно я кнопку просто скопировал с вашего файла и перенес ((((( СПАСИБО огромное!!!


Кто бы ты ни был, мир в твоих руках
 
Ответить
Сообщение_Boroda_, А точно я кнопку просто скопировал с вашего файла и перенес ((((( СПАСИБО огромное!!!

Автор - lebensvoll
Дата добавления - 07.04.2016 в 11:01
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Теория вероятности Определить теоретич значения для удаления (Макросы/Sub)
Страница 5 из 5«12345
Поиск:

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