Новости:

К первому сообщению темы должен быть прикреплен файл примера в формате xls*.
Приложив пример, Вы избавите себя и других от вопросов типа "А какой критерий?", "А куда выводить результат?", "А сколько строк?" и все тех же просьб выложить файл. Рисовать за Вас Ваши же таблички с заданиями, а затем и решение к ним, никто желанием не горит. Да и, как показывает практика, в большинстве случаев без файла решения не найти.

Главное меню

Подбор целых чисел по результату произведения их деления друг на друга

Автор el_fantomassito, 30.01.2013, 00:17

« назад - далее »

shanemac51a

у каждой модели станка --свой комплект шестеренок


Private Sub CommandButton1_Click()
MM130203_2157 Val(Range("e7").Value), Val(Range("e10").Value)

End Sub
Sub MM130203_2157(eps As Double, M0 As Double)
Dim XM, J1, J2, J3, j4, j8, KX1, KX2
'Dim M0 As Double
Dim M1 As Double
'Dim eps As Double
Dim m1abs As Double
Dim m1abs1 As Double
Columns("H:L").Select
Selection.ClearContents
'''''''''''''''''шестерни-конкретного станка-----------------
XM = Split("21,23,25,27,31,32,35,37,38,39,41,42,45,47,50,51,52,55,56,57,58,59,60,61,62,63,65", ",")
'''''''''''''''''передаточн число----------------
Debug.Print (46 / 52) * (22 / 45)            ''ошибка нет 22-45
Debug.Print (46 / 52) * (23 / 47)            '' контрольный расчет


'M0 = 0.43247832      '' (46 / 52) * (23 / 47)

M1 = 1
'eps = 0.000001
m1abs1 = M0 * 2
j8 = 1
KX1 = LBound(XM, 1)
KX2 = UBound(XM, 1)
Debug.Print "--------", Now, "------------"
Debug.Print M0; KX1; KX2; Format((46 / 52) * (23 / 47) - M0, "0.00000000")
J1 = KX1
Do While J1 < KX2
J2 = KX1
Do While J2 < KX2
J3 = KX1
   Do While J3 < KX2
   j4 = KX1
      Do While j4 < KX2
         If J1 = J2 Or J1 = J3 Or J1 = j4 Or J2 = J3 Or J2 = j4 Or J3 = j4 Then
         Else
         M1 = (XM(J3) * XM(j4)) / (XM(J1) * XM(J2))
         m1abs = Abs(M1 - M0)
         If m1abs < m1abs1 Then
            m1abs1 = m1abs
            Debug.Print XM(J1); " "; XM(J2); " "; XM(J3); " "; XM(j4); " "; M0; M1; Format(m1abs, "0.00000000")
            j8 = j8 + 1
            Cells(1, 8) = "ш1"
            Cells(1, 9) = "ш2"
            Cells(1, 10) = "ш3"
            Cells(1, 11) = "ш4"
            Cells(1, 12) = "отклонение"
            Cells(j8, 8) = XM(J1)
            Cells(j8, 9) = XM(J2)
            Cells(j8, 10) = XM(J3)
            Cells(j8, 11) = XM(j4)
            Cells(j8, 12) = Format(m1abs, "0.00000000")
            If m1abs1 < eps Then
            j8 = j8 + 1
            Cells(j8, 8) = "конец расчета"
            Debug.Print "конец расчета"
            Exit Sub
            End If
           
            j4 = j4 + 0
         End If
         End If
         j4 = j4 + 1
      Loop
   
   J3 = J3 + 1
   Loop
J2 = J2 + 1
Loop
J1 = J1 + 1
Loop


End Sub


el_fantomassito

MCH,посмотрел Ваш документ, как раз то , что нужно, только есть вопрос можно ли ряд шестерен ввести в тело макроса чтоб его не было видно и можно было добавлять и убирать шестерни.

Еще есть одно условие которое должно выполняться, так называемое "условие сцепляемости", в ячейках в которые выводятся гитары (23/45*55/65 например) должно выполнятся условие 23+45>55+20

MCH


el_fantomassito

Цитата: MCH от 08.02.2013, 08:40
так нужно?
СПАСИБО тоЧТО НУЖНО

el_fantomassito

При вводе результата деления более 1 макрос не работает, и как сделать, что бы выполнялось условие:

          i1/i2 * i3/i4.     должно выполняться i1+i2 > i3+20
                                                             i3+i4 > i2+20

shanemac51a


Private Sub CommandButton1_Click()
MM130203_2157 0.000001, (46 / 52) * (23 / 47)
MM130203_2157 0.000001, (47 / 52) * (23 / 46)
''В строке нет номера 46
''Есть ряд зубчатых колес 21,23,25,27,31,32,35,37,38,39,41,42,45,47,50,51,52,55,56,57,58,59.60,61,62,63,65.
''(как видим целые числа - это количество зубьев колеса).
''
''Есть расчитанное мной передаточное отношение - 0,43247832
''(результат деления, типа 46:52*22:45)
End Sub
Sub MM130203_2157(eps As Double, M0 As Double)
Dim XM, J1, J2, J3, j4, j8, KX1, KX2
'Dim M0 As Double
Dim M1 As Double
'Dim eps As Double
Dim m1abs As Double
Dim m1abs1 As Double
Columns("H:N").Select
Selection.ClearContents
'''''''''''''''''шестерни-конкретного станка-----------------
XM = Split("21,23,25,27,31,32,35,37,38,39,41,42,45,46,47,50,51,52,55,56,57,58,59,60,61,62,63,65", ",")
'''''''''''''''''передаточн число----------------
Debug.Print (46 / 52) * (22 / 45)            ''ошибка нет 22-45
Debug.Print (46 / 52) * (23 / 47)            '' контрольный расчет
'M0 = (46 / 52) * (23 / 47)

'M0 = 0.43247832      '' (46 / 52) * (23 / 47)

M1 = 1
'eps = 0.000001
m1abs1 = M0 * 1.5
j8 = 1
KX1 = LBound(XM, 1)
KX2 = UBound(XM, 1)
Debug.Print "--", Now, "--"; KX1; KX2; "m0="; M0
Debug.Print M0; KX1; KX2; Format((46 / 52) * (23 / 47) - M0, "0.00000000")
J1 = KX1
Do While J1 < KX2
J2 = 1 ''KX1
Do While J2 < KX2
J3 = 1 ''KX1
Do While J3 < KX2
j4 = 1 ''KX1
Do While j4 < KX2
If J1 = J2 Or J1 = J3 Or J1 = j4 Or J2 = J3 Or J2 = j4 Or J3 = j4 Then
Else
M1 = (XM(J3) * XM(j4)) / (XM(J1) * XM(J2))
m1abs = Abs(M1 - M0)
If m1abs < eps * 1.2 Then
'm1abs1 Then
m1abs1 = m1abs
Debug.Print XM(J1); " "; XM(J2); " "; XM(J3); " "; XM(j4); " "; M0; M1; Format(m1abs, "0.00000000")

' i1 i2 > i3 + 20
' i3 i4 > i2 + 20
j8 = j8 + 1
Cells(1, 8) = "ш1"
Cells(1, 9) = "ш2"
Cells(1, 10) = "ш3"
Cells(1, 11) = "ш4"
Cells(1, 12) = "отклонение"
Cells(j8, 8) = XM(J1)
Cells(j8, 9) = XM(J2)
Cells(j8, 10) = XM(J3)
Cells(j8, 11) = XM(j4)
Cells(j8, 12) = Format(m1abs, "0.00000000")
Cells(1, 13) = "конт12_3"
Cells(1, 14) = "конт34_2"

Cells(j8, 13) = (XM(J1) + XM(J2)) > (XM(J3) + 20)
Cells(j8, 14) = (XM(J3) + XM(j4)) > (XM(J2) + 20)
If Cells(j8, 13) = True And Cells(j8, 13) = True Then
j8 = j8 + 1
Cells(j8, 8) = "конец расчета1"
Debug.Print "конец расчета1"
Exit Sub
End If
If m1abs1 < eps Then
''
End If

j4 = j4 + 0 ''0
End If
End If
j4 = j4 + 1
Loop

J3 = J3 + 1
Loop
J2 = J2 + 1
Loop
J1 = J1 + 1
Loop
j8 = j8 + 1
Cells(j8, 8) = "конец расчета2"
Debug.Print "конец расчета2"
Exit Sub

End Sub


el_fantomassito


shanemac51a


el_fantomassito

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

shanemac51a

у меня считает
может вы не тот макрос по кнопке вызываете