Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 17.12.2012, 12:07   #11
DiemonStar
Старожил
 
Регистрация: 08.02.2012
Сообщений: 2,173
По умолчанию

Цитата:
Сообщение от Hugo121 Посмотреть сообщение
Ну да, так нужно опросить все 3 переменных (или 6 в общем случае), и произвести ещё 5 арифметических действий (или 4?)
Но зато записано элегантно. Но работает только с числами.
С точки зрения быстродействия (проверено на паскале), такая конструкция работает раза в 1,5 быстрее чем аналогичная при использовании or. Здесь многое от компилятора/интерпретатора зависит. На VBA не проверял.
Правильно поставленная задача - три четверти решения.
DiemonStar вне форума Ответить с цитированием
Старый 18.12.2012, 16:34   #12
nerv
Форумчанин
 
Аватар для nerv
 
Регистрация: 26.04.2010
Сообщений: 450
По умолчанию

Цитата:
Сообщение от Hugo121 Посмотреть сообщение
Ещё можно чуть ускорить, заменив
If n <> i And n <> j And n <> k Then
на
If n <> i Then
If n <> j Then
If n <> k Then
...
end if
end if
end if

Ну и выше тоже есть одно AND.
Так после первого несовпадения остальные проверки производиться не будут.
они и при And не производятся
Тишина – самый громкий звук
nerv вне форума Ответить с цитированием
Старый 02.02.2021, 09:34   #13
Антон Облёзин
Пользователь
 
Регистрация: 02.02.2021
Сообщений: 13
По умолчанию Ой!

Неудачное сообщение

Последний раз редактировалось Антон Облёзин; 02.02.2021 в 09:48.
Антон Облёзин вне форума Ответить с цитированием
Старый 02.02.2021, 09:46   #14
Антон Облёзин
Пользователь
 
Регистрация: 02.02.2021
Сообщений: 13
По умолчанию Мой расчёт

Первая версия программы. В следующих сообщениях выложу исправленную.
Вложения
Тип файла: xls Подбор гитары.xls (2.33 Мб, 1 просмотров)

Последний раз редактировалось Антон Облёзин; 03.02.2021 в 08:17.
Антон Облёзин вне форума Ответить с цитированием
Старый 02.02.2021, 10:26   #15
Aleksandr H.
2 the Nation Glory
Старожил
 
Аватар для Aleksandr H.
 
Регистрация: 27.05.2014
Сообщений: 3,289
По умолчанию

Некропостинг 9-летнего топика?

Цитата:
Сообщение от Антон Облёзин Посмотреть сообщение
да и об оформлении не заморачивался.
А зря. Подавляющее большинство не будут читать код не оформлен в тег [СODE][/СODE]
Кто умер, но не забыт, тот бессмертен.
Лао-Цзы.
Aleksandr H. вне форума Ответить с цитированием
Старый 03.02.2021, 08:33   #16
Антон Облёзин
Пользователь
 
Регистрация: 02.02.2021
Сообщений: 13
По умолчанию Мой расчёт

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

!!!
Если Вы захотите протестировать программу, будьте внимательны, расчёт занимает относительно много времени. Чтобы сократить время вычислений, рекомендую сократить список набора шестерён (таблица 1)
!!!

Прошу не ругать меня за плохое оформление и огрехи в программировании, я специалист в области машиностроения.

Собственно, сам код на VBA:

Код:

Sub Подбор_гитары()

' Очистка и укорачивание таблицы перед расчётом
Range("Таблица2").Select
Selection.ClearContents
ActiveSheet.ListObjects("Таблица2").Resize Range("$A$1:$F$2")


' Получение исходных данных
Set LO = Sheets("2. Подбор гитары шестерён").ListObjects("Таблица1")
LO.HeaderRowRange.Select ' Выбирается ячейка в таблице 1
Y = ActiveCell.Row + 1 ' Определяется координата строки первой строки ячейки
X = ActiveCell.Column ' Определяется координата столбца ячейки
A = Range("J10") ' Заносится значение количесвта строк в таблице
T = Range("M13").Value ' Переменная точности значащих цифр
F = Range("M11").Value ' Переменная исходного передаточного отношения
F1 = WorksheetFunction.Round(F, T)

Y1 = Y
Y2 = Y
Y3 = Y
Y4 = Y

' Вложенный цикл 4 порядка с перебором возможных соотношений

i = 1: j = 1: k = 1: m = 1: B = 0: C = 0: D = 2

For m = 1 To A

For k = 1 To A

For i = 1 To A
  
    For j = 1 To A
    
    Zd = Cells(Y1, X).Value
    Zc = Cells(Y2, X).Value
    Zb = Cells(Y3, X).Value
    Za = Cells(Y4, X).Value
    B5 = Za / Zb * Zc / Zd
    B6 = Abs(B5 - F)
    
    
' Условие точности
    E = B5
    E1 = WorksheetFunction.Round(E, T)
    If E1 = F1 Then
   
    ' Условие повторяемости шестерён
    If Y1 <> Y2 And Y1 <> Y3 And Y1 <> Y4 And Y2 <> Y3 And Y2 <> Y4 And Y3 <> Y4 Then
    
    'Условие сцепляемости шестерён
    If Za + Zb > Zc + 15 And Zc + Zd > Zb + 15 Then
    
    
    
    Cells(D, 1) = Za
    Cells(D, 2) = Zb
    Cells(D, 3) = Zc
    Cells(D, 4) = Zd
    Cells(D, 5) = B5
    Cells(D, 6) = B6
    
    D = D + 1
    
    Else
    End If
    
   Else
    End If
    
    
    Else
    End If
    
    
    Y1 = Y1 + 1
    Next j
    Y1 = Y
Y2 = Y2 + 1
Next i


Y2 = Y
Y3 = Y3 + 1


Next k


Y3 = Y
Y4 = Y4 + 1

Next m


' Сортировка таблицы по возрастанию погрешности

    ActiveWorkbook.Worksheets("2. Подбор гитары шестерён").ListObjects("Таблица2").Sort. _
        SortFields.Clear
    ActiveWorkbook.Worksheets("2. Подбор гитары шестерён").ListObjects("Таблица2").Sort. _
        SortFields.Add Key:=Range("Таблица2[[#All],[Погрешность]]"), SortOn:= _
        xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("2. Подбор гитары шестерён").ListObjects("Таблица2"). _
        Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With


' Удаление неиспользуемого диапазона строк


' Нахождение последней заполненной строки
LastRow = ActiveSheet.Cells.Find(What:="*", _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByRows).Row

' Нахождение последнего заполненного столбца
LastCOL = ActiveSheet.Cells.Find(What:="*", _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByColumns).Column

' Нахождение последнего незаполненного столбца
LastRow2 = ActiveCell.SpecialCells(xlLastCell).Row 'Заменяет нажатие Ctrl-End

If LastRow <> LastRow2 Then

' Удаление диапазона, ограниченного вышеуказанными переменными
Range(Cells(LastRow + 1, 1), Cells(LastRow2, LastCOL)).Delete shift:=xlUp

Else
End If

ActiveWorkbook.Save


End Sub
Вложения
Тип файла: xls Подбор гитары.xls (164.5 Кб, 3 просмотров)
Антон Облёзин вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Создание программы для управления некоторыми функциями другой программы Юрий1991 Общие вопросы Delphi 6 03.02.2012 15:32
Алгоритм подбора цвета по целому kraw2 Общие вопросы Delphi 3 30.11.2010 16:18
составление программы подбора символов... ssetxx Помощь студентам 0 15.10.2010 23:44
Спам атака методом подбора. Alex Cones Свободное общение 14 21.10.2009 11:22
Метод подбора (доделка программы ) soulmaster Помощь студентам 3 12.12.2007 11:12