Задача для макрописцев. Необходимо написать UDF, которое любое целое число от 2 до 2^31-1 раскладывала в виде произведения простых множителей. Если число простое, то функция должна возвратить значение "Prime"
Например, число 12 это 2*2*3, число 2 147 483 600 это 2*2*2*2*5*5*173*31033, 2 147 483 645 это 5*19*22605091, а число 2 147 483 647 является простым Необходимо написать достаточно быструю функцию, способную работать с большими числами, при этом желательно, чтобы она была лаконичной.
Примеры разложения некоторых чисел на множители - во вложении
Задача для макрописцев. Необходимо написать UDF, которое любое целое число от 2 до 2^31-1 раскладывала в виде произведения простых множителей. Если число простое, то функция должна возвратить значение "Prime"
Например, число 12 это 2*2*3, число 2 147 483 600 это 2*2*2*2*5*5*173*31033, 2 147 483 645 это 5*19*22605091, а число 2 147 483 647 является простым Необходимо написать достаточно быструю функцию, способную работать с большими числами, при этом желательно, чтобы она была лаконичной.
Примеры разложения некоторых чисел на множители - во вложенииMCH
Function MCH_F$(X&) Dim n1&, n2&, A(), j&, U&, Y& j = 0 Select Case X Case 0 To 3, 5, 7 MCH_F = "Prime" Exit Function End Select Do While X Mod 2 = 0 ReDim Preserve A(j) A(j) = 2 X = X / 2 j = j + 1 Loop Do While X Mod 3 = 0 ReDim Preserve A(j) A(j) = 3 X = X / 3 j = j + 1 Loop U = X \ 2 n1 = 5 n2 = 7 Do While n1 < U Y = X Do While X Mod n1 = 0 ReDim Preserve A(j) A(j) = n1 X = X / n1 j = j + 1 Loop If X Mod n2 = 0 Then ReDim Preserve A(j) A(j) = n2 X = X / n2 j = j + 1 End If If X <> Y Then U = X \ 2 End If n1 = n1 + 6 n2 = n1 + 2 Loop If j = 0 Then MCH_F = "Prime" Else If X <> 1 Then ReDim Preserve A(j) A(j) = X End If MCH_F = Join(A, "*") End If End Function
[/vba]
Михаил, привет.
Предлагаю такой вариант. Во вложении.
[vba]
Код
Function MCH_F$(X&) Dim n1&, n2&, A(), j&, U&, Y& j = 0 Select Case X Case 0 To 3, 5, 7 MCH_F = "Prime" Exit Function End Select Do While X Mod 2 = 0 ReDim Preserve A(j) A(j) = 2 X = X / 2 j = j + 1 Loop Do While X Mod 3 = 0 ReDim Preserve A(j) A(j) = 3 X = X / 3 j = j + 1 Loop U = X \ 2 n1 = 5 n2 = 7 Do While n1 < U Y = X Do While X Mod n1 = 0 ReDim Preserve A(j) A(j) = n1 X = X / n1 j = j + 1 Loop If X Mod n2 = 0 Then ReDim Preserve A(j) A(j) = n2 X = X / n2 j = j + 1 End If If X <> Y Then U = X \ 2 End If n1 = n1 + 6 n2 = n1 + 2 Loop If j = 0 Then MCH_F = "Prime" Else If X <> 1 Then ReDim Preserve A(j) A(j) = X End If MCH_F = Join(A, "*") End If End Function
Ограничил область перебираемых чисел, стало работать значительно быстрее.
[vba]
Код
Function MCH_F$(X&) Dim n1&, n2&, A(), j&, U&, Y& j = 0 Select Case X Case 0 To 3, 5, 7 MCH_F = "Prime" Exit Function End Select Do While X Mod 2 = 0 ReDim Preserve A(j) A(j) = 2 X = X / 2 j = j + 1 Loop Do While X Mod 3 = 0 ReDim Preserve A(j) A(j) = 3 X = X / 3 j = j + 1 Loop U = X \ 4 n1 = 5 n2 = 7 Do While n1 < U Y = X Do While X Mod n1 = 0 ReDim Preserve A(j) A(j) = n1 X = X / n1 j = j + 1 Loop If X Mod n2 = 0 Then ReDim Preserve A(j) A(j) = n2 X = X / n2 j = j + 1 End If U = X \ n2 n1 = n1 + 6 n2 = n1 + 2 Loop If j = 0 Then MCH_F = "Prime" Else If X <> 1 Then ReDim Preserve A(j) A(j) = X End If MCH_F = Join(A, "*") End If End Function
[/vba]
Ограничил область перебираемых чисел, стало работать значительно быстрее.
[vba]
Код
Function MCH_F$(X&) Dim n1&, n2&, A(), j&, U&, Y& j = 0 Select Case X Case 0 To 3, 5, 7 MCH_F = "Prime" Exit Function End Select Do While X Mod 2 = 0 ReDim Preserve A(j) A(j) = 2 X = X / 2 j = j + 1 Loop Do While X Mod 3 = 0 ReDim Preserve A(j) A(j) = 3 X = X / 3 j = j + 1 Loop U = X \ 4 n1 = 5 n2 = 7 Do While n1 < U Y = X Do While X Mod n1 = 0 ReDim Preserve A(j) A(j) = n1 X = X / n1 j = j + 1 Loop If X Mod n2 = 0 Then ReDim Preserve A(j) A(j) = n2 X = X / n2 j = j + 1 End If U = X \ n2 n1 = n1 + 6 n2 = n1 + 2 Loop If j = 0 Then MCH_F = "Prime" Else If X <> 1 Then ReDim Preserve A(j) A(j) = X End If MCH_F = Join(A, "*") End If End Function
Роман, твоя функция работает чуть быстрее моей (может быть за счет использования массива, я склеивал переменную). У меня функция строчек на 10-12. Я так понимаю, что ты используешь решето Аткина?
У тебя сбоит на некоторых числах, например на 343 раскладывает как 7*49, а должно быть 7*7*7
Роман, твоя функция работает чуть быстрее моей (может быть за счет использования массива, я склеивал переменную). У меня функция строчек на 10-12. Я так понимаю, что ты используешь решето Аткина?
У тебя сбоит на некоторых числах, например на 343 раскладывает как 7*49, а должно быть 7*7*7MCH
Спасибо, что заметил, Михаил. Я в одном месте два If превращал в Do While, один превратил, а на втором заснул =) Поправил. Теперь всё норм, прикладываю.
[vba]
Код
Function MCH_F$(X&) Dim n1&, n2&, A(), j&, U&, Y& j = 0 Select Case X Case 0 To 3, 5, 7 MCH_F = "Prime" Exit Function End Select Do While X Mod 2 = 0 ReDim Preserve A(j) A(j) = 2 X = X / 2 j = j + 1 Loop Do While X Mod 3 = 0 ReDim Preserve A(j) A(j) = 3 X = X / 3 j = j + 1 Loop U = X \ 4 n1 = 5 n2 = 7 Do While n1 < U Y = X Do While X Mod n1 = 0 ReDim Preserve A(j) A(j) = n1 X = X / n1 j = j + 1 Loop Do While X Mod n2 = 0 ReDim Preserve A(j) A(j) = n2 X = X / n2 j = j + 1 Loop U = X \ n2 n1 = n1 + 6 n2 = n1 + 2 Loop If j = 0 Then MCH_F = "Prime" Else If X <> 1 Then ReDim Preserve A(j) A(j) = X End If MCH_F = Join(A, "*") End If End Function
Скорее нет, чем да. Алгоритм я придумывал сам. Я заметил, что при поиске простых чисел можно использовать шаги по 12 и уже от этого отталкивался. Но, так получилось, что с решетом Аткина есть сходство.
Спасибо, что заметил, Михаил. Я в одном месте два If превращал в Do While, один превратил, а на втором заснул =) Поправил. Теперь всё норм, прикладываю.
[vba]
Код
Function MCH_F$(X&) Dim n1&, n2&, A(), j&, U&, Y& j = 0 Select Case X Case 0 To 3, 5, 7 MCH_F = "Prime" Exit Function End Select Do While X Mod 2 = 0 ReDim Preserve A(j) A(j) = 2 X = X / 2 j = j + 1 Loop Do While X Mod 3 = 0 ReDim Preserve A(j) A(j) = 3 X = X / 3 j = j + 1 Loop U = X \ 4 n1 = 5 n2 = 7 Do While n1 < U Y = X Do While X Mod n1 = 0 ReDim Preserve A(j) A(j) = n1 X = X / n1 j = j + 1 Loop Do While X Mod n2 = 0 ReDim Preserve A(j) A(j) = n2 X = X / n2 j = j + 1 Loop U = X \ n2 n1 = n1 + 6 n2 = n1 + 2 Loop If j = 0 Then MCH_F = "Prime" Else If X <> 1 Then ReDim Preserve A(j) A(j) = X End If MCH_F = Join(A, "*") End If End Function
Скорее нет, чем да. Алгоритм я придумывал сам. Я заметил, что при поиске простых чисел можно использовать шаги по 12 и уже от этого отталкивался. Но, так получилось, что с решетом Аткина есть сходство.
Сделал раздельный расчет (по примеру Романа) делимость на двойку и на все остальные, стало работать быстрее чем у Романа. Также есть решение формулами (используется множество ячеек), работает до чисел 2^40
Сделал раздельный расчет (по примеру Романа) делимость на двойку и на все остальные, стало работать быстрее чем у Романа. Также есть решение формулами (используется множество ячеек), работает до чисел 2^40MCH
'выводит все простые числа до корня из n в табличку Sub tblProst2(maxNum As Single)
Static k As Long Static j As Integer Static flP As Byte
j = 0 Worksheets("tbl").Activate Columns(1).ClearContents For k = 2 To Int(Sqr(maxNum)) If checkNum(k) Then j = j + 1 Cells(j, 1).Value = k End If Next k j = 0 End Sub
'основная функция
Public Sub disProst() Static chNumber As Double Static i As Long Static j As Long Static flEnd As Byte Static str1 As String Static t1 As Single Dim arrTbl() As Long
chNumber = CDbl(Worksheets("basa").Cells(1, 1)) If (chNumber - Int(chNumber)) > 0 Then MsgBox "Err: Дробное число": Exit Sub If chNumber < 4 Then MsgBox "Err: число меньше 4-х": Exit Sub t1 = Timer Application.StatusBar = "Идёт перебор вариантов..." 'AccelerateExcel
flEnd = 1 str1 = "1"
If checkNum(chNumber) Then str1 = str1 & "x" & "Prime" Else tblProst2 (chNumber) i = 1 Worksheets("tbl").Activate
j = Columns("A").Find("*", [A1], SearchDirection:=xlPrevious, LookIn:=xlValues).Row ReDim arrTbl(1 To j)
For i = 1 To j arrTbl(i) = Cells(i, 1) Next i Do For i = 1 To j If ModBig(chNumber, arrTbl(i)) = 0 Then str1 = str1 & "x" & arrTbl(i) chNumber = chNumber / arrTbl(i) If checkNum(chNumber) Then flEnd = 0: str1 = str1 & "x" & chNumber Exit For End If Next i Loop While flEnd End If Worksheets("basa").Activate str1 = Mid(str1, 3) Cells(2, 1) = str1 'disAccelerateExcel Application.StatusBar = "Перебор вариантов закончен" Cells(2, 2) = "Прошло: " & Int(Timer - t1) & "с"
End Sub ' ' проверяем простое число или нет Private Function checkNum(num) As Byte Static i As Single Static flP As Byte Static buff As Integer Static k As Single
flP = 1 k = Int(Sqr(num)) For i = 2 To k If ModBig(num, i) = 0 Then flP = 0: Exit For If ModBig(i, 1000) = 0 Then buff = DoEvents 'возвращаем операционке возможность действия, чтобы не было подвисания ''End If Next i checkNum = flP End Function
' 'замена вба мод для работы с большими числами Function ModBig(Num1, Num2) As Double ModBig = Num1 - Fix(Num1 / Num2) * Num2 End Function
[/vba]
а вот и мой трактор
[vba]
Код
'выводит все простые числа до корня из n в табличку Sub tblProst2(maxNum As Single)
Static k As Long Static j As Integer Static flP As Byte
j = 0 Worksheets("tbl").Activate Columns(1).ClearContents For k = 2 To Int(Sqr(maxNum)) If checkNum(k) Then j = j + 1 Cells(j, 1).Value = k End If Next k j = 0 End Sub
'основная функция
Public Sub disProst() Static chNumber As Double Static i As Long Static j As Long Static flEnd As Byte Static str1 As String Static t1 As Single Dim arrTbl() As Long
chNumber = CDbl(Worksheets("basa").Cells(1, 1)) If (chNumber - Int(chNumber)) > 0 Then MsgBox "Err: Дробное число": Exit Sub If chNumber < 4 Then MsgBox "Err: число меньше 4-х": Exit Sub t1 = Timer Application.StatusBar = "Идёт перебор вариантов..." 'AccelerateExcel
flEnd = 1 str1 = "1"
If checkNum(chNumber) Then str1 = str1 & "x" & "Prime" Else tblProst2 (chNumber) i = 1 Worksheets("tbl").Activate
j = Columns("A").Find("*", [A1], SearchDirection:=xlPrevious, LookIn:=xlValues).Row ReDim arrTbl(1 To j)
For i = 1 To j arrTbl(i) = Cells(i, 1) Next i Do For i = 1 To j If ModBig(chNumber, arrTbl(i)) = 0 Then str1 = str1 & "x" & arrTbl(i) chNumber = chNumber / arrTbl(i) If checkNum(chNumber) Then flEnd = 0: str1 = str1 & "x" & chNumber Exit For End If Next i Loop While flEnd End If Worksheets("basa").Activate str1 = Mid(str1, 3) Cells(2, 1) = str1 'disAccelerateExcel Application.StatusBar = "Перебор вариантов закончен" Cells(2, 2) = "Прошло: " & Int(Timer - t1) & "с"
End Sub ' ' проверяем простое число или нет Private Function checkNum(num) As Byte Static i As Single Static flP As Byte Static buff As Integer Static k As Single
flP = 1 k = Int(Sqr(num)) For i = 2 To k If ModBig(num, i) = 0 Then flP = 0: Exit For If ModBig(i, 1000) = 0 Then buff = DoEvents 'возвращаем операционке возможность действия, чтобы не было подвисания ''End If Next i checkNum = flP End Function
' 'замена вба мод для работы с большими числами Function ModBig(Num1, Num2) As Double ModBig = Num1 - Fix(Num1 / Num2) * Num2 End Function
Граждане трактористы, давайте смотреть правила той ветки форума, в которой постите. Мне вот уже неинтересно стало, даже пытаться не буду, хотя мысль была. И не нужно писать "А зачем тогда смотрел?". Да, знаю, любопытный я.
Граждане трактористы, давайте смотреть правила той ветки форума, в которой постите. Мне вот уже неинтересно стало, даже пытаться не буду, хотя мысль была. И не нужно писать "А зачем тогда смотрел?". Да, знаю, любопытный я._Boroda_
Rioran, поиздевался немного над твоим файлом. таки Redim Preserve - медленнее сцепления строк. в максимуме разница доходит до почти четырехкратной.
Rioran, поиздевался немного над твоим файлом. таки Redim Preserve - медленнее сцепления строк. в максимуме разница доходит до почти четырехкратной.ikki
ikki, классно получилось =) Новая скорость мне больше нравится. Но мне пришлось переделать то, как ты работаешь с библиотекой "kernel32", чтобы расчёт времени заработал на моей 64-х битной системе:
[vba]
Код
#If VBA7 Then Public Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long '64 Bit Systems #Else Public Declare Function GetTickCount Lib "kernel32" () As Long '32 Bit Systems #End If
[/vba]
ikki, классно получилось =) Новая скорость мне больше нравится. Но мне пришлось переделать то, как ты работаешь с библиотекой "kernel32", чтобы расчёт времени заработал на моей 64-х битной системе:
[vba]
Код
#If VBA7 Then Public Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long '64 Bit Systems #Else Public Declare Function GetTickCount Lib "kernel32" () As Long '32 Bit Systems #End If
Т.к. решения уже выложены, то выкладываю собственное решение. Сделано на формулах и через UDF, работает для чисел 2^40 (и для больших, формулы ограничены 40 множителями, но это очень легко исправить для формул ограничение именно 2^40 т.к. строк на листе всего 1048576)
Т.к. решения уже выложены, то выкладываю собственное решение. Сделано на формулах и через UDF, работает для чисел 2^40 (и для больших, формулы ограничены 40 множителями, но это очень легко исправить для формул ограничение именно 2^40 т.к. строк на листе всего 1048576)MCH
Мой код на типах Long работает немного быстрее, чем на Double, разница в коде - только в объявлении типов переменных. Но Double позволяет разложить на множители число состоящие из пятнадцати девяток: 999999999999999 = 3*3*3*31*37*41*271*2906161 Для больших чисел происходит потеря точности связанная с типом Double. Для Long ограничение - 2^31-1
Мой код на типах Long работает немного быстрее, чем на Double, разница в коде - только в объявлении типов переменных. Но Double позволяет разложить на множители число состоящие из пятнадцати девяток: 999999999999999 = 3*3*3*31*37*41*271*2906161 Для больших чисел происходит потеря точности связанная с типом Double. Для Long ограничение - 2^31-1MCH
Попробовал переделать свой код под 2^40, теперь первичная настройка занимает почти 4 мин , но последующие считает меньше 1 сек. 1 099 511 627 773 =13x84577817521 (Прошло: 0,6796875с)
== Сократил первичку до 70с
Попробовал переделать свой код под 2^40, теперь первичная настройка занимает почти 4 мин , но последующие считает меньше 1 сек. 1 099 511 627 773 =13x84577817521 (Прошло: 0,6796875с)
С учетом ограничения 2 до 2^31-1 и быстродействия Разработал функцию, которая, в самом сложном варианте 2 147 483 647, считает мгновенно (у меня выдает максимум 4 миллисекунды) Размер функции порядка 40 строк + дополнительные данные на скрытом листе
С учетом ограничения 2 до 2^31-1 и быстродействия Разработал функцию, которая, в самом сложном варианте 2 147 483 647, считает мгновенно (у меня выдает максимум 4 миллисекунды) Размер функции порядка 40 строк + дополнительные данные на скрытом листеmiver
Размер функции порядка 40 строк + дополнительные данные на скрытом листе
код, который я опубликовал ранее, переведя на Long (вместо Double) [vba]
Код
Function PrimeFact2$(ByVal n&) Dim i&, txt$ While n Mod 2 = 0 And n > 3 n = n \ 2 txt = txt & "*2" Wend i = 3 While CDbl(i) * i <= n If n Mod i Then i = i + 2 Else n = n \ i: txt = txt & "*" & i Wend If txt = "" Then PrimeFact2 = "Prime" Else PrimeFact2 = Mid$(txt, 2) & "*" & n End Function
[/vba] Всего состоит из 12 строчек, и на 1000 повторений для числа 2 147 483 647 работает менее секунды (0,6 - 0,625 сек./1000 повторений на моем компьютере, т.е. 0,6 миллисекунды на одно повторение)
Размер функции порядка 40 строк + дополнительные данные на скрытом листе
код, который я опубликовал ранее, переведя на Long (вместо Double) [vba]
Код
Function PrimeFact2$(ByVal n&) Dim i&, txt$ While n Mod 2 = 0 And n > 3 n = n \ 2 txt = txt & "*2" Wend i = 3 While CDbl(i) * i <= n If n Mod i Then i = i + 2 Else n = n \ i: txt = txt & "*" & i Wend If txt = "" Then PrimeFact2 = "Prime" Else PrimeFact2 = Mid$(txt, 2) & "*" & n End Function
[/vba] Всего состоит из 12 строчек, и на 1000 повторений для числа 2 147 483 647 работает менее секунды (0,6 - 0,625 сек./1000 повторений на моем компьютере, т.е. 0,6 миллисекунды на одно повторение)MCH
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
, но последующие считает меньше 1 сек. 
