Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel (архив)
Страницы: 1 2 След.
RSS
Фильтр в цикле
 
#1
30.09.2009 14:20:19
есть макрос  
Sub перебор_комбинаций()  
Dim myAraj()  
Dim i, j, k, l, m, myRows, p  
myRows = 1  
For i = 1 To 6  
   For j = i + 1 To 7  
       For k = j + 1 To 8  
           For l = k + 1 To 9  
               For m = l + 1 To 10  
                 Cells(myRows, 1) = i  
                 Cells(myRows, 2) = j  
                 Cells(myRows, 3) = k  
                 Cells(myRows, 4) = l  
                 Cells(myRows, 5) = m  
                 myRows = myRows + 1  
               Next m  
           Next l  
       Next k  
   Next j  
Next i  
 
End Sub  
 
всего комбинаций 252  
 
Как отфильтровать подряд идущих цифр больше 2-х в строке. Например, 1 2 3, 8 9 10, и так далее и комбинаций будет намного меньше.
 
 
 
#2
30.09.2009 14:33:25
т.е надо исключить 123 ,,, 234,... 345... и т.д. или 12 и 89 , 23 и 78 и т.д.    
и то и другое более двух подряд идущих цифр.
 
 
 
#3
30.09.2009 14:43:54
Так?  
 
 
Sub перебор_комбинаций()  
Dim myAraj()  
Dim i, j, k, l, m, myRows, p  
myRows = 1  
For i = 1 To 6  
For j = i + 1 To 7  
For k = j + 1 To 8  
For l = k + 1 To 9  
For m = l + 1 To 10  
Cells(myRows, 1) = i  
Cells(myRows, 2) = j  
Cells(myRows, 3) = k  
Cells(myRows, 4) = l  
Cells(myRows, 5) = m  
myRows = myRows + 1  
Next m  
Next l  
Next k  
Next j  
Next i  
For i = myRows - 1 To 1 Step -1  
For k = 3 To 5  
If (Cells(i, k) - Cells(i, k - 1) = 1) And (Cells(i, k - 1) - Cells(i, k - 2) = 1) Then  
Rows(i).EntireRow.Hidden = True ' Rows(i).Delete  
Exit For  
End If  
Next  
Next  
End Sub
Bite my shiny metal ass!      
 
 
 
#4
30.09.2009 14:52:43
Если исключить все варианты, где есть числа подряд, то в твоем примере останется всего шесть вариантов:  
1; 3; 5; 7; 9  
1; 3; 5; 7; 10  
1; 3; 5; 8; 10  
1; 3; 6; 8; 10  
1; 4; 6; 8; 10  
2; 4; 6; 8; 10
 
 
 
#5
30.09.2009 15:02:38
a макрос такой6  
 
Sub ïåðåáîð_êîìáèíàöèé()  
 
Dim i, j, k, l, m, myRows  
myRows = 1  
For i = 1 To 10  
For j = i + 2 To 10  
For k = j + 2 To 10  
For l = k + 2 To 10  
For m = l + 2 To 10  
Cells(myRows, 1) = i  
Cells(myRows, 2) = j  
Cells(myRows, 3) = k  
Cells(myRows, 4) = l  
Cells(myRows, 5) = m  
myRows = myRows + 1  
Next m  
Next l  
Next k  
Next j  
Next i  
End Sub
 
 
 
#6
30.09.2009 15:09:46
игрок, Вы когда все деньги мира выиграете, отпишите сюда. Будем хоть знать, что помогли в создании "формулы успеха"
Bite my shiny metal ass!      
 
 
 
#7
30.09.2009 15:18:03
{quote}{login=Михаил}{date=30.09.2009 02:52}{thema=}{post}Если исключить все варианты, где есть числа подряд, то в твоем примере останется всего шесть вариантов:  
1; 3; 5; 7; 9  
1; 3; 5; 7; 10  
1; 3; 5; 8; 10  
1; 3; 6; 8; 10  
1; 4; 6; 8; 10  
2; 4; 6; 8; 10{/post}{/quote}  
 
нет не шесть вариантов, а больше 2 подряд числа учитываются  
макрос предложены Лузером работает  
только как вернуть строки, подряд.  
 
Есть еще один вопрос если этим генератором сформировать 42 - 5 то вариантов должно бить 850668 строк, а ексель больше чем 65536 нет и выдает ошибку, как удлинить лист екселя по строкам
 
 
 
#8
30.09.2009 15:22:02
{quote}{login=игрок}{date=30.09.2009 03:18}{thema=Re: }{post}как удлинить лист екселя по строкам{/post}{/quote}  
 
Установить Excel 2007 - там более миллиона строк на листе.
Надстройки для Excel  Парсинг сайтов  Мониторинг цен конкурентов
 
 
 
#9
30.09.2009 15:27:09
{quote}{login=Лузер™}{date=30.09.2009 03:09}{thema=}{post}игрок, Вы когда все деньги мира выиграете, отпишите сюда. Будем хоть знать, что помогли в создании "формулы успеха"{/post}{/quote}  
 
Что могу сказать про форум то он интересен и хорош.  
 
"формулы успеха" на верное нет, только фильтрами и статистикой можно приблизится к успеху на чуть-чуть.  
 
Если получится создать что-то в этом роде обязательно поделюсь.
 
 
 
#10
30.09.2009 15:39:29
Чтобы вернуть "подряд" вместо: Rows(i).EntireRow.Hidden = True пишите Rows(i).Delete - я там в комментарии дал специально.  
Я не прошу формулу успеха.  
Я прошу сообщить. что она у Вас заработал :)
Bite my shiny metal ass!      
 
 
 
#11
30.09.2009 16:04:32
Лузер™  
Я не прошу формулу успеха.  
 
Во во формула нам не нужна ... нам бы результат ее работы, по чуть чуть.
 
 
 
#12
30.09.2009 16:08:03
Для формулы успеха:  
Чтобы не городить лишних строк  
 
Sub перебор_комбинаций()  
 
Dim myAraj(1 To 5)  
Dim i, j, k, l, m, myRows, p, o  
myRows = 1  
For i = 1 To 6  
 myAraj(1) = i  
 For j = i + 1 To 7  
   myAraj(2) = j  
   For k = j + 1 To 8  
     myAraj(3) = k  
     For l = k + 1 To 9  
       myAraj(4) = l  
       For m = l + 1 To 10  
         myAraj(5) = m  
         p = True  
         For o = 3 To 5  
           If (myAraj(o) - myAraj(o - 1) = 1) And (myAraj(o - 1) - myAraj(o - 2) = 1) Then  
             p = False  
             Exit For  
           End If  
         Next  
         If p Then  
           Cells(myRows, 1) = myAraj(1)  
           Cells(myRows, 2) = myAraj(2)  
           Cells(myRows, 3) = myAraj(3)  
           Cells(myRows, 4) = myAraj(4)  
           Cells(myRows, 5) = myAraj(5)  
           myRows = myRows + 1  
         End If  
       Next m  
     Next l  
   Next k  
 Next j  
Next i  
 
End Sub
Bite my shiny metal ass!      
 
 
 
#13
30.09.2009 16:19:01
так побыстрее будет:  
 
Sub перебор_комбинаций()  
 
Dim myAraj(1 To 5)  
Dim i, j, k, l, m, myRows, p, o  
myRows = 1  
For i = 1 To 6  
 For j = i + 1 To 7  
   For k = j + 1 To 8  
     If Not ((k - j = 1) And (j - i = 1)) Then  
       For l = k + 1 To 9  
         If Not ((l - k = 1) And (k - j = 1)) Then  
           For m = l + 1 To 10  
             If Not ((m - l = 1) And (l - k = 1)) Then  
               Cells(myRows, 1) = i  
               Cells(myRows, 2) = j  
               Cells(myRows, 3) = k  
               Cells(myRows, 4) = l  
               Cells(myRows, 5) = m  
               myRows = myRows + 1  
             End If  
           Next m  
         End If  
       Next l  
     End If  
   Next k  
 Next j  
Next i  
 
End Sub
Bite my shiny metal ass!      
 
 
 
#14
30.09.2009 16:48:53
{quote}{login=Лузер™}{date=30.09.2009 04:19}{thema=}{post}так побыстрее будет:  
 
 
     If Not ((k - j = 1) And (j - i = 1)) Then  
       For l = k + 1 To 9  
         If Not ((l - k = 1) And (k - j = 1)) Then  
           For m = l + 1 To 10  
             If Not ((m - l = 1) And (l - k = 1)) Then  
                 
 
End Sub{/post}{/quote}  
 
   Как бы фильтр усложнит  
1. Фильтр на максимум 3 фиксованных и две переменны  
Например 1 2 4 5 7  
        1 2 4 8 9  
а с 4 фиксованными отфильтровать  
Например 1 2 4 5 7  
        1 2 4 5 8  
1.Аналогично сделать второй фильтр только на 2 фиксованых а 2 и 3 отфильтровать
 
 
 
#15
30.09.2009 16:55:20
{quote}{login=игрок}{date=30.09.2009 04:48}{thema=Re: }{post}{quote}{login=Лузер™}{date=30.09.2009 04:19}{thema=}{post}так побыстрее будет:  
 
 
     If Not ((k - j = 1) And (j - i = 1)) Then  
       For l = k + 1 To 9  
         If Not ((l - k = 1) And (k - j = 1)) Then  
           For m = l + 1 To 10  
             If Not ((m - l = 1) And (l - k = 1)) Then  
                 
 
End Sub{/post}{/quote}  
 
   Как бы фильтр усложнит  
1. Фильтр на максимум 3 фиксованных и две переменны  
Например 1 2 4 5 7  
        1 2 4 8 9  
а с 4 фиксованными отфильтровать  
Например 1 2 4 5 7  
        1 2 4 5 8  
1.Аналогично сделать второй фильтр только на 2 фиксованых а 3 и 4 отфильтровать{/post}{/quote}
 
 
 
#16
30.09.2009 16:56:20
Как бы ничего не понял.  
Я и первый-то раз с трудом идею понял.  
А сейчас так вообще...
Bite my shiny metal ass!      
 
 
 
#17
30.09.2009 17:15:59
вот макрос, чтоб в 2003 помещался...  
Option Explicit  
 
Sub перебор_комбинаций()  
Application.ScreenUpdating = False  
Dim myAraj(1 To 5)  
Dim i, j, k, l, m, myRows, p, o  
myRows = 1  
p = 0  
For i = 1 To 38  
For j = i + 1 To 39  
For k = j + 1 To 40  
If Not ((k - j = 1) And (j - i = 1)) Then  
For l = k + 1 To 41  
If Not ((l - k = 1) And (k - j = 1)) Then  
For m = l + 1 To 42  
If Not ((m - l = 1) And (l - k = 1)) Then  
Cells(myRows, p + 1) = i  
Cells(myRows, p + 2) = j  
Cells(myRows, p + 3) = k  
Cells(myRows, p + 4) = l  
Cells(myRows, p + 5) = m  
myRows = myRows + 1  
If myRows = 65000 Then p = p + 7  
If myRows = 65000 Then myRows = 1  
 
End If  
Next m  
End If  
Next l  
End If  
Next k  
Next j  
Next i  
Application.ScreenUpdating = True  
End Sub  
 
А на счет последнего пожелания ...  думать надо...
 
 
 
#18
30.09.2009 17:43:26
{quote}{login=Лузер™}{date=30.09.2009 04:56}{thema=}{post}Как бы ничего не понял.  
Я и первый-то раз с трудом идею понял.  
А сейчас так вообще...{/post}{/quote}  
 
В общем, идея в том чтобы создать все возможные варианты, например 5 из 42, это полная комбинация, а потом отфильтровать.    
 
Три и более подряд цифр никогда не выпадают на это уже есть фильтр цикла.  
 
А вот чтобы создать  неполную систему. Например, если угадать 5 цифр из 42, то, что б была гарантирована 3 (так званая неполная система), в цикле надо как-то отфильтровать чтоб 1 вариант с 3 цифрами повторялся только 1 раз.
 
 
 
#19
30.09.2009 18:23:57
ЭХ, решал я подобную задачу еще на Z-Spectrum 64K, в начале 90-х... если по тетрадкам поискать - то должны быть и алгоритмы всякие. Прога по перебору вариантов - еще с той поры...  
зы. правда следующее мое знакомство с компом произошло, когда уже 2007 офис уже был не новинкой....
 
 
 
#20
30.09.2009 18:44:44
Вот пример:  
 
Sub MyTest()  
Dim Т_Д() 'Создаем массив данных  
Dim Ст1, Ст2, Ст3, Ст4, Ст5, Ст6, Стр, teim1, teim2 'переменные строк и cтолбцов  
Стр = 1  
Dim TheRange As Range  
teim1 = Timer  
Application.ScreenUpdating = False  
'For Ст1 = 1 To 7  
'If Ст1 = 2 Or Ст1 = 5 Then Ст1 = Ст1 + 1  
  ' For Ст2 = Ст1 + 1 To 8  
   'If Ст2 = 2 Or Ст2 = 5 Then Ст2 = Ст2 + 1  
       For Ст3 = Ст2 + 1 To 40  
       If Ст3 = 2 Or Ст3 = 5 Then Ст3 = Ст3 + 1  
           For Ст4 = Ст3 + 1 To 41  
           If Ст4 = 2 Or Ст4 = 5 Then Ст4 = Ст4 + 1  
               For Ст5 = Ст4 + 1 To 42  
               If Ст5 = 2 Or Ст5 = 5 Then Ст5 = Ст5 + 1  
                   ReDim Preserve Т_Д(1 To 5, 1 To Стр)  
                   Т_Д(1, Стр) = 2  
                   Т_Д(2, Стр) = 5  
                   Т_Д(3, Стр) = Ст3  
                   Т_Д(4, Стр) = Ст4  
                   Т_Д(5, Стр) = Ст5  
                     
                  Стр = Стр + 1  
 
               Next Ст5  
           Next Ст4  
       Next Ст3  
   'Next Ст2  
'Next Ст1  
Set TheRange = Range(Cells(2, 1), Cells(Стр, 5))  
 
TheRange.Value = Application.WorksheetFunction.Transpose(Т_Д)  
teim2 = Timer  
Application.ScreenUpdating = True  
 
MsgBox (teim2 - teim1)  
End Sub  
 
Здесь я в качестве примера взял два числа - 2 и 5 как постоянные. На основе этого примера можешь делать свои.
 
 
 
#21
30.09.2009 19:20:47
{quote}{login=Михаил}{date=30.09.2009 06:23}{thema=}{post}ЭХ, решал я подобную задачу еще на Z-Spectrum 64K, в начале 90-х... {/post}{/quote}  
Да уж... Ностальгия... Я Спектрумы-32 собирал. Машина была на то время - зверь :)
 
 
 
#22
01.10.2009 17:08:36
{quote}{login=Михаил}{date=30.09.2009 06:44}{thema=}{post}Вот пример:  
 
Sub MyTest()  
Dim Т_Д() 'Создаем массив данных  
Dim Ст1, Ст2, Ст3, Ст4, Ст5, Ст6, Стр, teim1, teim2 'переменные строк и cтолбцов  
Стр = 1  
Dim TheRange As Range  
teim1 = Timer  
Application.ScreenUpdating = False  
'For Ст1 = 1 To 7  
'If Ст1 = 2 Or Ст1 = 5 Then Ст1 = Ст1 + 1  
  ' For Ст2 = Ст1 + 1 To 8  
   'If Ст2 = 2 Or Ст2 = 5 Then Ст2 = Ст2 + 1  
       For Ст3 = Ст2 + 1 To 40  
       If Ст3 = 2 Or Ст3 = 5 Then Ст3 = Ст3 + 1  
           For Ст4 = Ст3 + 1 To 41  
           If Ст4 = 2 Or Ст4 = 5 Then Ст4 = Ст4 + 1  
               For Ст5 = Ст4 + 1 To 42  
               If Ст5 = 2 Or Ст5 = 5 Then Ст5 = Ст5 + 1  
                   ReDim Preserve Т_Д(1 To 5, 1 To Стр)  
                   Т_Д(1, Стр) = 2  
                   Т_Д(2, Стр) = 5  
                   Т_Д(3, Стр) = Ст3  
                   Т_Д(4, Стр) = Ст4  
                   Т_Д(5, Стр) = Ст5  
                     
                  Стр = Стр + 1  
 
               Next Ст5  
           Next Ст4  
       Next Ст3  
   'Next Ст2  
'Next Ст1  
Set TheRange = Range(Cells(2, 1), Cells(Стр, 5))  
 
TheRange.Value = Application.WorksheetFunction.Transpose(Т_Д)  
teim2 = Timer  
Application.ScreenUpdating = True  
 
MsgBox (teim2 - teim1)  
End Sub  
 
Здесь я в качестве примера взял два числа - 2 и 5 как постоянные. На основе этого примера можешь делать свои.{/post}{/quote}  
 
Все нормально только не могу фильтр вписать, чтоб подряд идущие цифры больше 2 небело в строке вместе с фиксованными,    
например  2 5 1 3 6
 
 
 
#23
01.10.2009 18:28:58
Две, три, четыре подряд.... "...ни тем путем идете, товарищ!"(С).  
Вероятность попадания 1; 2; 3 и, скажем, 14; 26; 39 - абсолютно одинакова, и откидывая идущие три подряд.. в общем, тебе это ничего не даст.    
Если у тебя есть база тиражей, алгоритм примерно таков:  
1) по каждому шару в отдельности проверяешь, как часто выпадает, когда был последний раз;  
2) по каждой паре шаров (например 1 и 2; 5 и 23) - то же самое;  
3) тоже самое - по каждой тройке;    
4)тоже самое по каждой четверке; если шаров шесть, то и по пятеркам.  
Далее, принимаем в качестве ограничения, что:  
-если вариант выпал, то второй раз не выпадет  
-если какая-то четверка шаров (из пяти) выпала - второй раз не выпадет (впрочем, об этом можно судить по статистике п.4);  
-далее, на сновании статистики по парам, с учетом отдельных шаров и троек делаем прогноз на наиболее вероятные  10 (ну, или 12- 15) шаров на ближайший тираж.    
Затем, в зависимости от азарта и количества не нужных денег заполняем все варианты по выбранным шарам.  
 
Все выше сказанное имеет какой-то смысл, если все время используется один и тоже комплект шаров и один и тоже "лохотрон". При смене хотя бы одного шара вся статистика летит к черту.
 
 
 
#24
02.10.2009 04:40:55
>> "Все нормально только не могу фильтр вписать, чтоб подряд идущие цифры больше 2 небело в строке вместе с фиксованными," <<    
Ну если еще актуально, то держи
 
 
 
#25
02.10.2009 10:12:16
{quote}{login=Михаил}{date=02.10.2009 04:40}{thema=}{post}>> "Все нормально только не могу фильтр вписать, чтоб подряд идущие цифры больше 2 небело в строке вместе с фиксованными," <<    
Ну если еще актуально, то держи{/post}{/quote}  
 
Очень большое спасибо за помощь в решении моей так званой задачи.  
 
Хочу открыть другую тему.    
 
Как из таблицы данных сделать график по заданным критериям, чтоб сделать статистику
 
 
 
#26
02.10.2009 10:48:09
{quote}{login=игрок}{date=02.10.2009 10:12}{thema=Из Таблицы график}{post}{quote}{login=Михаил}{date=02.10.2009 04:40}{thema=}{post}>> "Все нормально только не могу фильтр вписать, чтоб подряд идущие цифры больше 2 небело в строке вместе с фиксованными," <<    
Ну если еще актуально, то держи{/post}{/quote}Хочу открыть другую тему. {/post}{/quote}  
Хотите новую - тогда СОЗДАЙТЕ новую тему. Этот пост будет удалён (после появления новой темы. В Правилах об этом сказано отдельно (п. 4).
 
 
 
#27
02.10.2009 11:54:18
Извините больше не буду, я думал что тема:..., автоматически создастся.
 
 
 
#28
14.01.2010 17:04:46
есть хорошая идея для создания умного фильтра для лотерей есть часть решенной задачи, а до конца доделать не могу, файл могу сбросить только не в эху.
 
 
 
#29
14.01.2010 19:00:43
{quote}{login=игрок}{date=14.01.2010 05:04}{thema=Re: }{post}есть хорошая идея для создания умного фильтра для лотерей есть часть решенной задачи, а до конца доделать не могу, файл могу сбросить только не в эху.{/post}{/quote}Ну так покажите файл. Только за размером следите.
 
 
 
#30
01.02.2010 15:26:46
{quote}{login=Михаил}{date=14.01.2010 07:00}{thema=Re: Re: }{post}{quote}{login=игрок}{date=14.01.2010 05:04}{thema=Re: }{post}есть хорошая идея для создания умного фильтра для лотерей есть часть решенной задачи, а до конца доделать не могу, файл могу сбросить только не в эху.{/post}{/quote}Ну так покажите файл. Только за размером следите.{/post}{/quote}  
 
есть два файла    
1 идея она весит около 100кб, что и как должно работать  
2 файл программы которая недоделанная 2мб.  
 
Все это я приобрел за деньги, человек оказался не честный, сказал, что она у него работала когда-то, после получения моих денег. В файле чего-то нахватает только не могу разобраться. сбросьте свой емел и я переброшу этих два файла, помогите разобраться плиз.
 
 
 
Страницы: 1 2 След.
Читают тему
Наверх