Форум программистов, компьютерный форум, киберфорум
Наши страницы
VBA
Войти
Регистрация
Восстановить пароль
 
Рейтинг 5.00/5: Рейтинг темы: голосов - 5, средняя оценка - 5.00
Romalllka
0 / 0 / 0
Регистрация: 14.05.2013
Сообщений: 9
1

Проблемы с оптимизацией

14.05.2013, 17:53. Просмотров 976. Ответов 14
Метки нет (Все метки)

Добрый день. Совсем недавно начал осваивать VBA в Excel, но не получается уменьшить код. Приведу его кусок, я думаю, что он может быть меньше 40 строк, которые занимает, помоги пожалуйста. Спасибо
Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
                Cells(10, 9).Copy _
                Destination:=Cells(12, 7)
                Cells(10, 13).Copy _
                Destination:=Cells(13, 7)
                Cells(10, 17).Copy _
                Destination:=Cells(14, 7)
                Cells(10, 21).Copy _
                Destination:=Cells(15, 7)
                Cells(10, 25).Copy _
                Destination:=Cells(16, 7)
                
              '...
                Cells(1, 7).Copy _
                Destination:=Cells(12, 6)
                Cells(1, 11).Copy _
                Destination:=Cells(13, 6)
                Cells(1, 15).Copy _
                Destination:=Cells(14, 6)
                Cells(1, 19).Copy _
                Destination:=Cells(15, 6)
                Cells(1, 23).Copy _
                Destination:=Cells(16, 6)
0
Similar
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
14.05.2013, 17:53
Ответы с готовыми решениями:

Нужна подсказка с оптимизацией кода
Штука такая: решил сделать таймер отсчёта времени, по окончании которого процедура идёт далее....

Помогите с оптимизацией выборки с oracle сервера
Добрый день. Исходные данные: С ораклового сервера производиться выборка и помещается в темповый...

Проблемы с оптимизацией
Добавил на страницу ключевых слов, итог в Яше по этому запросу был на 60, вылез на 26. А в Гоше был...

Помогите с оптимизацией!
Ребята, может кто сможет по -доброте душевной помочь с оптимизацией сайта? :) Сама я...

Помогите с оптимизацией
Доброго времени суток. у меня сайт pornstardata.ru(для взрослых, кому меньше 18 даже не смотрите)....

14
Апострофф
Заблокирован
14.05.2013, 18:10 2
Первый шаг - убрать переносы
Visual Basic
1
2
3
4
5
6
Cells(10, 9).Copy Destination:=Cells(12, 7)
Cells(10, 13).Copy Destination:=Cells(13, 7)
Cells(10, 17).Copy Destination:=Cells(14, 7)
Cells(10, 21).Copy Destination:=Cells(15, 7)
Cells(10, 25).Copy Destination:=Cells(16, 7)
' и т.д.
А дальше мутить с циклами, поскольку линейная зависимость индексов очевидна.
0
toiai
3147 / 911 / 206
Регистрация: 29.05.2010
Сообщений: 1,977
14.05.2013, 18:21 3
Можно занести координаты копирующих ячеек в Массив1, а куда копировать в Массив2,
а потом ...
Visual Basic
1
2
3
For i=LBound(Массив1) to UBound(Массив1)
       Cells(Массив1(i,1), Массив1(i,2)).Copy Destination:=Cells(Массив2(i,1), Массив2(i,2))
Next
0
Апострофф
Заблокирован
14.05.2013, 18:32 4
Visual Basic
1
2
3
4
5
for i=12 to 16
  cells(i,7)=cells(10,4*i-39)
  '...
  cells(i,6)=cells(1,4*i-41)
next i
Вот весь приведенный фрагмент от ТС в четырех строках.
1
14.05.2013, 18:32
Romalllka
0 / 0 / 0
Регистрация: 14.05.2013
Сообщений: 9
14.05.2013, 22:26  [ТС] 5
Спасибо. я чувствовал, что линейная зависимость есть, но шел не в том направлении поэтому начался ступор...
0
Romalllka
0 / 0 / 0
Регистрация: 14.05.2013
Сообщений: 9
15.05.2013, 11:36  [ТС] 6
на данный момент опять наступил ступор. Есть данные, мы считаем очки. в результате очки получаем. выводим их в таблицу с указанием имени участника + подсчет угаданных матчей (дополнительный критерий) при упорядочивании. Нам необходимо упорядочить таблицу согласно набранным очкам. При равных очках, смотрим кто больше угадал. Не получается никаким образом это сделать, может я опять ошибся где-то на каком-то витке своих мыслей? Спасибо. Код и файл прикладываю
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
Sub FFF()
    For i = 2 To 9 Step 1 'Перебираем строки
        For k = 9 To 85 Step 4 'Столбец результатов
            Z = k - 2 'ставка забитых мячей домашней команды
            y = k - 1 'ставка забитых мячей гостевой команды
            
                'обнуляем пропущенные ставки
                If Cells(i, Z).Value = Empty And Cells(i, y).Value = Empty Then
                    Cells(i, k).Value = 0
                Else
                
                'считаем набранные очки
                    If ((Cells(i, 2).Value = Cells(i, Z).Value And Cells(i, 3).Value = Cells(i, y).Value) And (Cells(i, 2).Value + Cells(i, 3).Value >= 5)) Then
                        Cells(i, k).Value = 7 '3 очка за угаданный матч + 4 бонусных за результативный матч
                        ElseIf (Cells(i, 2).Value = Cells(i, Z).Value And Cells(i, 3).Value = Cells(i, y).Value) Then Cells(i, k).Value = 3 'за угаданный 3 очка
                        ElseIf (Cells(i, 2).Value - Cells(i, 3).Value <> 0 And Cells(i, 2).Value - Cells(i, 3).Value = Cells(i, Z).Value - Cells(i, y).Value) Then Cells(i, k).Value = 1.5 'За разницу 1,5 очка
                        ElseIf (Cells(i, 2).Value - Cells(i, 3).Value = 0 And Cells(i, Z).Value - Cells(i, y).Value = 0 And Cells(i, 2).Value = Cells(i, 3).Value) Then Cells(i, k).Value = 1 'Ничья 1 очко
                        ElseIf (Cells(i, 2).Value - Cells(i, 3).Value > 0 And Cells(i, Z).Value - Cells(i, y).Value > 0) Then Cells(i, k).Value = 1 'За исход 1 очко
                        ElseIf (Cells(i, 2).Value - Cells(i, 3).Value < 0 And Cells(i, Z).Value - Cells(i, y).Value < 0) Then Cells(i, k).Value = 1 'За исход 1 очко
                        Else: Cells(i, k).Value = 0 'В остальном случае 0
                    End If
                End If
                     'Итого у каждого участника
                      Cells(10, k).Value = WorksheetFunction.Sum(Range(Cells(2, k), Cells(9, k)))
        Next
    Next
    
    'составление таблицы
                
                For i = 12 To 31
                  Cells(i, 7) = Cells(10, 4 * i - 39) 'собираем очки
                  Cells(i, 6) = Cells(1, 4 * i - 41) 'собираем участников
                Next i
                
                'считаем количество угаданных матчей игроками
 
                For i = 12 To 31 'Step 1
                  Cells(i, 8).Value = WorksheetFunction.CountIf(Columns(4 * i - 39), "3")
                Next i
               
 
End Sub
0
Вложения
Тип файла: rar Kopia_Ver1_2_2 .rar (24.9 Кб, 3 просмотров)
Апострофф
Заблокирован
15.05.2013, 12:40 7
А что, запись макроса не так работает?
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Sub Макрос2()
'
' Макрос2 Макрос
'
 
'
    Range("F11:H31").Select
    ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Add Key:=Range("G12:G31") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Add Key:=Range("H12:H31") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Лист1").Sort
        .SetRange Range("F11:H31")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
1
Romalllka
0 / 0 / 0
Регистрация: 14.05.2013
Сообщений: 9
15.05.2013, 12:42  [ТС] 8
премного благодарен, про запись макроса из головы вылетело ((( я уже начал вгонять таблицу в массив, думал с ним поработать. Как иногда хорошо трезвым взглядом оценить!
0
Romalllka
0 / 0 / 0
Регистрация: 14.05.2013
Сообщений: 9
15.05.2013, 16:39  [ТС] 9
Бета версия готова, но вкралась ошибка. Для примера ввел результат матча Динамо-Краснодар. ввел ставки участников. в графу НТ вводятся очки на начало тура. Они суммируются с штрафными очками за тур(Ш) и очками за тур(О) и выводятся в итоговую таблицу(О). Значения НТ введены вручную, после прошлых туров. Но после нажатия кнопки считать, данные в таблице за тур правильные, но в итоговой таблице бардак, потому что меняются данные в графе НТ. Не могу понять почему. Из-за этого летит Итоговая таблица. Если есть время, посмотрите плиз
Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
Sub FFF()
    For i = 2 To 9 Step 1 'Перебираем строки
        For k = 9 To 85 Step 4 'Столбец результатов
            Z = k - 2 'ставка забитых мячей домашней команды
            y = k - 1 'ставка забитых мячей гостевой команды
            
                'обнуляем пропущенные ставки
                If Cells(i, Z).Value = Empty And Cells(i, y).Value = Empty Then
                    Cells(i, k).Value = 0
                Else
                'обнуление матчей, которых еще нет
 
                If Cells(i, 2).Value = "" And Cells(i, 3).Value = "" Then
                    Cells(i, k).Value = 0
                    Else
                'считаем набранные очки
                    If ((Cells(i, 2).Value = Cells(i, Z).Value And Cells(i, 3).Value = Cells(i, y).Value) And (Cells(i, 2).Value + Cells(i, 3).Value >= 5)) Then
                        Cells(i, k).Value = 7 '3 очка за угаданный матч + 4 бонусных за результативный матч
                        ElseIf (Cells(i, 2).Value = Cells(i, Z).Value And Cells(i, 3).Value = Cells(i, y).Value) Then Cells(i, k).Value = 3 'за угаданный 3 очка
                        ElseIf (Cells(i, 2).Value - Cells(i, 3).Value <> 0 And Cells(i, 2).Value - Cells(i, 3).Value = Cells(i, Z).Value - Cells(i, y).Value) Then Cells(i, k).Value = 1.5 'За разницу 1,5 очка
                        ElseIf (Cells(i, 2).Value - Cells(i, 3).Value = 0 And Cells(i, Z).Value - Cells(i, y).Value = 0 And Cells(i, 2).Value = Cells(i, 3).Value) Then Cells(i, k).Value = 1 'Ничья 1 очко
                        ElseIf (Cells(i, 2).Value - Cells(i, 3).Value > 0 And Cells(i, Z).Value - Cells(i, y).Value > 0) Then Cells(i, k).Value = 1 'За исход 1 очко
                        ElseIf (Cells(i, 2).Value - Cells(i, 3).Value < 0 And Cells(i, Z).Value - Cells(i, y).Value < 0) Then Cells(i, k).Value = 1 'За исход 1 очко
                        Else: Cells(i, k).Value = 0 'В остальном случае 0
                    End If
                    End If
                End If
                     'Итого у каждого участника
                      Cells(10, k).Value = WorksheetFunction.Sum(Range(Cells(2, k), Cells(9, k)))
        Next
    Next
    
    'составление таблицы
                
                For i = 12 To 31
                  Cells(i, 7) = Cells(10, 4 * i - 39) 'собираем очки
                  Cells(i, 6) = Cells(1, 4 * i - 41) 'собираем участников
                Next i
                
                'считаем количество угаданных матчей игроками
 
                For i = 12 To 31 'Step 1
                  Cells(i, 8).Value = WorksheetFunction.CountIf(Columns(4 * i - 39), "3") + WorksheetFunction.CountIf(Columns(4 * i - 39), "7")
                Next i
               
              ' создание таблицы через массив
               'Dim table(3, 20) As Variant
               'Dim x As Long
               'For x = 1 To 19 '
                'For i = 12 To 31
                'table(1, x) = Cells(1, 4 * i - 41) 'заполнили участников
                'table(2, x) = Cells(10, 4 * i - 39) 'заполнили очки
                'table(3, x) = WorksheetFunction.CountIf(Columns(4 * i - 39), "3") + WorksheetFunction.CountIf(Columns(4 * i - 39), "7") 'заполнили угаданные матчи
                'Next
               'Next
               'MsgBox table(1, 18)
               
               
               'Упорядочим нашу таблицу
        Range("F11:H31").Select
           ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Clear
           ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Add Key:=Range("G12:G31") _
               , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
           ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Add Key:=Range("H12:H31") _
               , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
           With ActiveWorkbook.Worksheets("Лист1").Sort
               .SetRange Range("F11:H31")
               .Header = xlYes
               .MatchCase = False
               .Orientation = xlTopToBottom
               .SortMethod = xlPinYin
               .Apply
           End With
           
           'Итоговая таблица
           
           
           For x = 34 To 53
                'Участники
                Cells(x, 6).Value = Cells(x - 22, 6)
                'Считаем общие очки
                Cells(x, 7).Value = WorksheetFunction.Sum(Cells(x - 22, 11), Cells(x - 22, 7), Cells(x - 22, 9))
                'Считаем общие угаданные матчи
                Cells(x, 8).Value = WorksheetFunction.Sum(Cells(x - 22, 12), Cells(x - 22, 8))
           Next
' упорядочим итоговую
 
    ActiveWindow.SmallScroll Down:=15
    Range("F33:H53").Select
    ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Add Key:=Range("G34:G53") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Add Key:=Range("H34:H53") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Add Key:=Range("F34:F53") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Лист1").Sort
        .SetRange Range("F33:H53")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
        
        
End Sub
0
Вложения
Тип файла: rar Ver2.1 - копия.rar (30.8 Кб, 4 просмотров)
Romalllka
0 / 0 / 0
Регистрация: 14.05.2013
Сообщений: 9
16.05.2013, 08:38  [ТС] 10
думаю косяк в строках 82 и 84, там где я считаю сумму в итоговую таблицу...но тогда не знаю как просуммировать правильно
Цитата Сообщение от Romalllka Посмотреть сообщение
Бета версия готова, но вкралась ошибка. Для примера ввел результат матча Динамо-Краснодар. ввел ставки участников. в графу НТ вводятся очки на начало тура. Они суммируются с штрафными очками за тур(Ш) и очками за тур(О) и выводятся в итоговую таблицу(О). Значения НТ введены вручную, после прошлых туров. Но после нажатия кнопки считать, данные в таблице за тур правильные, но в итоговой таблице бардак, потому что меняются данные в графе НТ. Не могу понять почему. Из-за этого летит Итоговая таблица. Если есть время, посмотрите плиз
Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
Sub FFF()
    For i = 2 To 9 Step 1 'Перебираем строки
        For k = 9 To 85 Step 4 'Столбец результатов
            Z = k - 2 'ставка забитых мячей домашней команды
            y = k - 1 'ставка забитых мячей гостевой команды
            
                'обнуляем пропущенные ставки
                If Cells(i, Z).Value = Empty And Cells(i, y).Value = Empty Then
                    Cells(i, k).Value = 0
                Else
                'обнуление матчей, которых еще нет
 
                If Cells(i, 2).Value = "" And Cells(i, 3).Value = "" Then
                    Cells(i, k).Value = 0
                    Else
                'считаем набранные очки
                    If ((Cells(i, 2).Value = Cells(i, Z).Value And Cells(i, 3).Value = Cells(i, y).Value) And (Cells(i, 2).Value + Cells(i, 3).Value >= 5)) Then
                        Cells(i, k).Value = 7 '3 очка за угаданный матч + 4 бонусных за результативный матч
                        ElseIf (Cells(i, 2).Value = Cells(i, Z).Value And Cells(i, 3).Value = Cells(i, y).Value) Then Cells(i, k).Value = 3 'за угаданный 3 очка
                        ElseIf (Cells(i, 2).Value - Cells(i, 3).Value <> 0 And Cells(i, 2).Value - Cells(i, 3).Value = Cells(i, Z).Value - Cells(i, y).Value) Then Cells(i, k).Value = 1.5 'За разницу 1,5 очка
                        ElseIf (Cells(i, 2).Value - Cells(i, 3).Value = 0 And Cells(i, Z).Value - Cells(i, y).Value = 0 And Cells(i, 2).Value = Cells(i, 3).Value) Then Cells(i, k).Value = 1 'Ничья 1 очко
                        ElseIf (Cells(i, 2).Value - Cells(i, 3).Value > 0 And Cells(i, Z).Value - Cells(i, y).Value > 0) Then Cells(i, k).Value = 1 'За исход 1 очко
                        ElseIf (Cells(i, 2).Value - Cells(i, 3).Value < 0 And Cells(i, Z).Value - Cells(i, y).Value < 0) Then Cells(i, k).Value = 1 'За исход 1 очко
                        Else: Cells(i, k).Value = 0 'В остальном случае 0
                    End If
                    End If
                End If
                     'Итого у каждого участника
                      Cells(10, k).Value = WorksheetFunction.Sum(Range(Cells(2, k), Cells(9, k)))
        Next
    Next
    
    'составление таблицы
                
                For i = 12 To 31
                  Cells(i, 7) = Cells(10, 4 * i - 39) 'собираем очки
                  Cells(i, 6) = Cells(1, 4 * i - 41) 'собираем участников
                Next i
                
                'считаем количество угаданных матчей игроками
 
                For i = 12 To 31 'Step 1
                  Cells(i, 8).Value = WorksheetFunction.CountIf(Columns(4 * i - 39), "3") + WorksheetFunction.CountIf(Columns(4 * i - 39), "7")
                Next i
               
              ' создание таблицы через массив
               'Dim table(3, 20) As Variant
               'Dim x As Long
               'For x = 1 To 19 '
                'For i = 12 To 31
                'table(1, x) = Cells(1, 4 * i - 41) 'заполнили участников
                'table(2, x) = Cells(10, 4 * i - 39) 'заполнили очки
                'table(3, x) = WorksheetFunction.CountIf(Columns(4 * i - 39), "3") + WorksheetFunction.CountIf(Columns(4 * i - 39), "7") 'заполнили угаданные матчи
                'Next
               'Next
               'MsgBox table(1, 18)
               
               
               'Упорядочим нашу таблицу
        Range("F11:H31").Select
           ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Clear
           ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Add Key:=Range("G12:G31") _
               , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
           ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Add Key:=Range("H12:H31") _
               , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
           With ActiveWorkbook.Worksheets("Лист1").Sort
               .SetRange Range("F11:H31")
               .Header = xlYes
               .MatchCase = False
               .Orientation = xlTopToBottom
               .SortMethod = xlPinYin
               .Apply
           End With
           
           'Итоговая таблица
           
           
           For x = 34 To 53
                'Участники
                Cells(x, 6).Value = Cells(x - 22, 6)
                'Считаем общие очки
                Cells(x, 7).Value = WorksheetFunction.Sum(Cells(x - 22, 11), Cells(x - 22, 7), Cells(x - 22, 9))
                'Считаем общие угаданные матчи
                Cells(x, 8).Value = WorksheetFunction.Sum(Cells(x - 22, 12), Cells(x - 22, 8))
           Next
' упорядочим итоговую
 
    ActiveWindow.SmallScroll Down:=15
    Range("F33:H53").Select
    ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Add Key:=Range("G34:G53") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Add Key:=Range("H34:H53") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Add Key:=Range("F34:F53") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Лист1").Sort
        .SetRange Range("F33:H53")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
        
        
End Sub
Добавлено через 37 минут
косяк вроде нашел. был он в хитром месте, точнее в двух надо было исправить первое упорядочивание, и в цикле не указал Next x (85строка)

Добавлено через 4 минуты
странно, если удалить результат матча, и нажать считать еще раз, все равно он путает таблицу, почему?

Добавлено через 14 часов 45 минут
тема все еще актуальна, не могу найти почему делает пересорт значений вводимых руками. Голова пухнет!
0
Апострофф
Заблокирован
16.05.2013, 08:59 11
Romalllka, приложите последнюю версию файла и объясните проблему поподробнее.
0
Romalllka
0 / 0 / 0
Регистрация: 14.05.2013
Сообщений: 9
16.05.2013, 09:09  [ТС] 12
Программа работает отлично включая место с построением итоговой таблицы за тур. Считает, сортирует правильно. Дальше задача сделать итоговую таблицу по всем турам, для этого нужно прибавить очки за тур (о) штрафы за тур (ш) и очки на начало тура (НТ). Тоже самое с угаданными матчами (у). Порядок действий. сначала ставятся прогнозы участниками. Потом ставится результат матча (одного) допустим первый 2-0. Нажимаем считать. Итоговая таблица за тур работает. Она сортируется, но при этом сбиваются очки (НТ) из-за этого происходит ошибка в итоговой таблице, где не тем прибавляется не то.
Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
Sub FFF()
    For i = 2 To 9 Step 1 'Перебираем строки
        For k = 9 To 85 Step 4 'Столбец результатов
            Z = k - 2 'ставка забитых мячей домашней команды
            y = k - 1 'ставка забитых мячей гостевой команды
            
                'обнуляем пропущенные ставки
                If Cells(i, Z).Value = Empty And Cells(i, y).Value = Empty Then
                    Cells(i, k).Value = 0
                Else
                'обнуление матчей, которых еще нет
 
                If Cells(i, 2).Value = "" And Cells(i, 3).Value = "" Then
                    Cells(i, k).Value = 0
                    Else
                'считаем набранные очки
                    If ((Cells(i, 2).Value = Cells(i, Z).Value And Cells(i, 3).Value = Cells(i, y).Value) And (Cells(i, 2).Value + Cells(i, 3).Value >= 5)) Then
                        Cells(i, k).Value = 7 '3 очка за угаданный матч + 4 бонусных за результативный матч
                        ElseIf (Cells(i, 2).Value = Cells(i, Z).Value And Cells(i, 3).Value = Cells(i, y).Value) Then Cells(i, k).Value = 3 'за угаданный 3 очка
                        ElseIf (Cells(i, 2).Value - Cells(i, 3).Value <> 0 And Cells(i, 2).Value - Cells(i, 3).Value = Cells(i, Z).Value - Cells(i, y).Value) Then Cells(i, k).Value = 1.5 'За разницу 1,5 очка
                        ElseIf (Cells(i, 2).Value - Cells(i, 3).Value = 0 And Cells(i, Z).Value - Cells(i, y).Value = 0 And Cells(i, 2).Value = Cells(i, 3).Value) Then Cells(i, k).Value = 1 'Ничья 1 очко
                        ElseIf (Cells(i, 2).Value - Cells(i, 3).Value > 0 And Cells(i, Z).Value - Cells(i, y).Value > 0) Then Cells(i, k).Value = 1 'За исход 1 очко
                        ElseIf (Cells(i, 2).Value - Cells(i, 3).Value < 0 And Cells(i, Z).Value - Cells(i, y).Value < 0) Then Cells(i, k).Value = 1 'За исход 1 очко
                        Else: Cells(i, k).Value = 0 'В остальном случае 0
                    End If
                    End If
                End If
                     'Итого у каждого участника
                      Cells(10, k).Value = WorksheetFunction.Sum(Range(Cells(2, k), Cells(9, k)))
        Next
    Next
    
    'составление таблицы
                
                For i = 12 To 31
                  Cells(i, 7) = Cells(10, 4 * i - 39) 'собираем очки
                  Cells(i, 6) = Cells(1, 4 * i - 41) 'собираем участников
                Next i
                
                'считаем количество угаданных матчей игроками
 
                For i = 12 To 31 'Step 1
                  Cells(i, 8).Value = WorksheetFunction.CountIf(Range(Cells(2, 4 * i - 39), Cells(9, 4 * i - 39)), "3") + WorksheetFunction.CountIf(Range(Cells(2, 4 * i - 39), Cells(9, 4 * i - 39)), "7")
                Next i
               
              ' создание таблицы через массив
               'Dim table(3, 20) As Variant
               'Dim x As Long
               'For x = 1 To 19 '
                'For i = 12 To 31
                'table(1, x) = Cells(1, 4 * i - 41) 'заполнили участников
                'table(2, x) = Cells(10, 4 * i - 39) 'заполнили очки
                'table(3, x) = WorksheetFunction.CountIf(Columns(4 * i - 39), "3") + WorksheetFunction.CountIf(Columns(4 * i - 39), "7") 'заполнили угаданные матчи
                'Next
               'Next
               'MsgBox table(1, 18)
               
               
               'Упорядочим нашу таблицу
    Range("F12:L31").Select
    ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Add Key:=Range("G12:G31") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Add Key:=Range("H12:H31") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Лист1").Sort
        .SetRange Range("F12:L31")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
           
           'Итоговая таблица
           
           
           For x = 34 To 53
                'Участники
                Cells(x, 6).Value = Cells(x - 22, 6)
                'Считаем общие очки
                Cells(x, 7).Value = WorksheetFunction.Sum(Cells(x - 22, 11), Cells(x - 22, 7), Cells(x - 22, 9))
                'Считаем общие угаданные матчи
                Cells(x, 8).Value = WorksheetFunction.Sum(Cells(x - 22, 12), Cells(x - 22, 8))
           Next x
' упорядочим итоговую
 
    ActiveWindow.SmallScroll Down:=15
    Range("F33:H53").Select
    ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Add Key:=Range("G34:G53") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Add Key:=Range("H34:H53") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Add Key:=Range("F34:F53") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Лист1").Sort
        .SetRange Range("F33:H53")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
        
        
End Sub
0
Вложения
Тип файла: rar Ver2.1 - копия.rar (31.7 Кб, 4 просмотров)
Romalllka
0 / 0 / 0
Регистрация: 14.05.2013
Сообщений: 9
16.05.2013, 13:56  [ТС] 13
наверное не работает связь построчно в таблице за тур? Но я в некотором ступоре. спасибо

Добавлено через 4 часа 45 минут
Апострофф, удалось посмотреть?
0
Аксима
5889 / 1278 / 191
Регистрация: 12.12.2012
Сообщений: 1,001
16.05.2013, 16:37 14
Здравствуйте, Romalllka,
Не волнуйтесь, Апострофф обязательно посмотрит работу и все вам по полочкам разложит.

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

Если окажется, что я прав - то возможных путей решения вашей проблемы два: либо проверка того, что соответствие было нарушено, прогулка по таблице со словарем туда-сюда и возвращаение строк таблицы на прежнее место (сложно), либо хранение фамилий и данных по очкам + угаданным исходам в отдельной таблице, где их никто пальцем не тронет (проще).

Пример реализации второго пути - в приложении.

С уважением,
Aksima
P.S. Кстати, количество строк кода в оригинальном файле - более 100, в приложенном файле - ровно 25 строк. Это к вопросу о возможностях по оптимизации вашего приложения.
1
Вложения
Тип файла: rar FootballBets.rar (23.9 Кб, 4 просмотров)
Romalllka
0 / 0 / 0
Регистрация: 14.05.2013
Сообщений: 9
16.05.2013, 16:59  [ТС] 15
Спасибо, сяду изучать!
Сам пошел пока по другому пути, правда явно не оптимальному

Добавлено через 47 секунд
Aksima,
Решение гениальное! Мне есть к чему стремится ))
сам пошел по другому пути, сократив таблицу упорядочивания до рабочей версии, добавил 2 кнопки.
Добавление очков (НО) происходит из итоговой таблицы. Т.е. изначально записали в итоговую таблицу результаты > провели тур, нажали кнопку 1, она посчитала исправно таблицу за тур, выставив всех как надо. нажали кнопку 2, она добавила в соответствии с именем нужное значение в (НО) из итоговой таблицы за прошлый тур. Нажали кнопку 3, она посчитала итоговую таблицу после текущего суммой ячеек.
Таким образом замкнул тур и подготовил его к следующему.
0
16.05.2013, 16:59
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
16.05.2013, 16:59

прблемы с оптимизацией
пишу на вижуал с 2008... проблема вот в чем - пока компилирую код просто так - вс пркрасно....

Помогите с оптимизацией
Есть сайт pcinfoportal.net.ru Помогите прооптимизировать его под поисковики. Что надо еще...

Помогите с оптимизацией
Подскажи плиз с сайтом _www.atis-ars.ru. Сейчас сайт по словосочитанию &quot;охрана труда&quot; находится на...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
15
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2019, vBulletin Solutions, Inc.
Рейтинг@Mail.ru