Страницы: Пред. 1 2 3 4 5 6 7 След.
RSS
Подборка функций пользователя
 
Evgenyy, спасибо
 
artyrH, пользуйтесь!
 
Написал очередную UDF: PrimeFactors - разложение натуральных чисел на простые множители. Смотрите пример в файле.

Код
Public Function PrimeFactors(Number As Double) As Variant
    Dim mn As Long
    If Number < 2 Or Number >= 1000000000000# Or Int(Number) <> Number Then
        PrimeFactors = vbNullString
        Exit Function
    End If
    ReDim Rez(0)
    mn = 2
    Do While CDbl(mn) * mn <= Number
        If Int(Number / mn) = Number / mn Then
            Number = Number / mn
            Rez(UBound(Rez)) = mn
            ReDim Preserve Rez(UBound(Rez) + 1)
        Else
            If mn = 2 Then mn = 3 Else mn = mn + 2
        End If
    Loop
    If UBound(Rez) = 0 Then
        ReDim Preserve Rez(Application.Caller.Columns.Count - 1)
        Rez(0) = "прост. число"
        For mn = 1 To UBound(Rez)
            Rez(mn) = vbNullString
        Next mn
    Else
        Rez(UBound(Rez)) = Number
    End If
    PrimeFactors = Rez
End Function
 
Интересно. Позволю себе несколько примечаний.
1.Алгоритм можно несколько модифицировать (см. ниже ссылку, если будет интересно).
2.Диапазон можно расширить до 2^63, через LongLong (18 знаков) или использовать Decimal (29 знаков)
Сам когда-то писал подобное (правда, на другом языке).
В итоге знаков 30 щелкает за секунды (все зависит от общего количества простых делителей).
Конечно это слабовато, считаю, но писать что-то серьезное не было мотивации.
Несколько рекомендаций, в блоге, возможно, будут интересны читающим (за исключением того, что это все же другой язык, а данная тема - это VBA ).
Изменено: bedvit - 14.11.2019 20:13:44
«Бритва Оккама» или «Принцип Калашникова»?
 
bedvit,  добрый вечер!
"Чем обусловлен диапазон до 10^12 (12 цифр в ячейке)?" - спросит пользователь. Всё очень просто - визуализацией числа в ячейке. Чем длиннее число, тем больше размер ячейки или меньше размер шрифта. Я для себя определил верхний предел в 12 цифр.
Функция как отправная точка, как готовое решение. Дальше каждый сам для себя решает увеличить диапазон или нет. Я думаю, принимая во внимание Ваши рекомендации, это не составит большого труда.
Изменено: Evgenyy - 14.11.2019 21:45:39
 
Цитата
Evgenyy написал:
"Чем обусловлен диапазон до 10^12 (12 цифр в ячейке)?" - спросит пользователь. Всё очень просто - визуализацией числа в ячейке.
никогда результат вычисления не привязывал к визуальному виду в ячейке (всегда ориентировался на мах возможности), потому как, у каждого свои вкусы. А мах возможности - это решение универсальное.
Цитата
Evgenyy написал:
Я для себя определил верхний предел в 12 цифр.
мне нравится, к примеру, 15 знаков - уже ваше решение не подходит :) Ну если, вы делаете только для себя, то все норм.
«Бритва Оккама» или «Принцип Калашникова»?
 
Вот, кстати, делал для Excel аналогичные функции (только вывод не в массив, а через разделитель) - Факторизация натурального числа, поиск простых делителей, поиск всех делителей.
+Проверка простое ли число или составное.
Изменено: bedvit - 15.11.2019 13:22:07
«Бритва Оккама» или «Принцип Калашникова»?
 
Цитата
bedvit написал:
Ну если, вы делаете только для себя
Делаю для себя, делюсь со всеми. Каждый пользователь вправе модифицировать код под свои запросы.

Цитата
bedvit написал:
никогда результат вычисления не привязывал к визуальному виду в ячейке
Для меня важны и форма и содержание, с философской точки зрения.
Изменено: Evgenyy - 17.11.2019 22:46:15
 
Добрый вечер!

Пишу понемногу. Замахнулся на "великий и могучий" русский язык.
Написал очередную UDF: Hyphenation - деление простых слов (не составных, не слов-исключений) на части при переносе слов в тексте с одной строки на другую. Смотрите пример в файле.

Код
Public Function Hyphenation(Word As String) As Variant
    Dim i As Byte, j As Byte, k As Byte, l As Byte, p As Byte
    Dim gl As String, gs As String, sg As String, l1 As String
    Dim l2 As String, l3 As String, l4 As String, l5 As String
    Dim s1 As String, s2 As String, s3 As String, s4 As String
    Application.Volatile
    If Len(Word) < 4 Then Hyphenation = vbNullString: Exit Function
    gl = "[аеёиоуыэюя]"
    For i = 1 To Len(Word)
        If Mid(Word, i, 1) Like gl Then k = k + 1
    Next i
    If k = 0 Then Hyphenation = vbNullString: Exit Function
    If k = 1 Then
        ReDim Rez(0) As String
        Rez(0) = Word
    Else
        ReDim Rez(k - 1) As String
        l = 0: p = 1
        l1 = Left(Word, 2): l2 = Left(Word, 3)
        l3 = Left(Word, 4): l4 = Left(Word, 5): l5 = Left(Word, 6)
        gs = "[аеёиоуэюя]": sg = "[бвгджзклмнпрстфхцчшщ]"
        For i = 0 To k - 2
            For j = p To Len(Word) - 1
                s1 = Mid(Word, j, 1): s2 = Mid(Word, j + 1, 1)
                s3 = Mid(Word, j + 2, 1): s4 = Mid(Word, j + 3, 1)
                If s1 Like gl Then
                    If (s2 Like gl And Not (j = 2 And l2 = "наи")) Or _
                        (s2 Like sg And s3 = "ь" And s4 Like gs And Not i = k - 2) Or _
                        (s2 Like sg And (s3 Like gl Or Right(Word, 2) Like "ь[еёиюя]") And Not _
                        (((j = 2 Or j = 4) And (l2 = "без" Or l2 = "воз" Or l2 = "дез" Or l2 = "меж" _
                        Or l2 = "раз" Or l2 = "под")) Or (j = 3 And (l1 = "до" Or l1 = "за" _
                        Or l1 = "со")) Or (j = 4 And (l2 = "изо" Or l2 = "вне" Or l2 = "наи" _
                        Or l2 = "обо" Or l2 = "ото" Or (l2 = "пре" And s2 <> "д") Or l2 = "при" _
                        Or l2 = "про" Or l2 = "адъ" Or l2 = "взъ" Or l2 = "изъ" Or l2 = "инъ" _
                        Or l2 = "объ")) Or ((j = 3 Or j = 5) And (l3 = "чрез" Or l3 = "пред")) _
                        Or (j = 5 And (l3 = "дизъ" Or l3 = "конъ" Or l3 = "межъ" Or l3 = "подъ" _
                        Or l3 = "разъ" Or l3 = "субъ")) Or (j = 6 And (l4 = "сверх" Or l4 = "транс" _
                        Or l4 = "предъ")) Or (j = 7 And (l5 = "интеръ" Or l5 = "контръ" Or l5 = "суперъ")) _
                        Or (s3 = "ь" And s4 Like sg And Right(Word, 2) Like "ь[еёиюя]"))) Or _
                        (j = 2 And (l1 = "во" Or l1 = "вы" Or l1 = "до" Or l1 = "за" Or l1 = "не" Or l1 = "по" _
                        Or l1 = "ра" Or l1 = "со") And s2 Like "[жс]" And s3 = s2 And s4 Like gl) Or _
                        (((j = 2 And (l1 = "вы" Or l1 = "до" Or l1 = "за" Or l1 = "со")) _
                        Or (j = 3 And (l2 = "изо" Or l2 = "вне" Or l2 = "наи" Or l2 = "обо" _
                        Or l2 = "ото" Or (l2 = "пре" And s2 <> "д") Or l2 = "при" Or l2 = "про")) _
                        Or (j = 4 And (l3 = "анти" Or l3 = "архи" Or l3 = "водо" Or l3 = "возо" _
                        Or l3 = "недо" Or l3 = "пере" Or l3 = "подо")) Or (j = 5 And (l4 = "возле" _
                        Or l4 = "инфра" Or l4 = "около" Or l4 = "предо" Or l4 = "прото")) _
                        Or (j = 6 And l5 = "ультра")) And s2 Like sg And s3 Like sg) Then
                        Rez(i) = Mid(Word, p, j - l): p = j + 1: Exit For
                    ElseIf s2 = "й" Or (s2 Like sg And s3 Like sg And Not ((((i = k - 3 Or i = k - 2) _
                        And ((s2 = "д" And s3 = "ж") Or (s2 = "р" And s3 Like "[гджзпт]") _
                        Or (s2 Like "[зн]" And s3 = "д") Or (s2 Like "[дкнсфх]" And s3 = "т") _
                        Or (s2 = "с" And s3 = "к")) And s4 Like sg) Or s4 = "ь") Or (j = 1 And l2 = "экс") _
                        Or (j = 2 And l4 = "контр") Or (j = 3 And (l4 = "транс" Or l4 = "сверх")))) Or _
                        (((j = 2 And (l2 = "без" Or l2 = "воз" Or l2 = "дез" Or l2 = "меж" Or l2 = "раз" _
                        Or l2 = "под")) Or (j = 3 And (l3 = "пред" Or l3 = "чрез"))) And s3 Like gs) Then
                        Rez(i) = Mid(Word, p, j - l + 1): p = j + 2: Exit For
                    ElseIf (s2 Like sg And s3 Like "[ъь]") Or (s2 Like sg And s3 Like sg And _
                        Not (s4 = "ь" Or (j = 2 And l4 = "контр" And Right(l5, 1) Like sg))) Then
                        Rez(i) = Mid(Word, p, j - l + 2): p = j + 3: Exit For
                    ElseIf s2 Like sg And s3 Like sg And (s4 = "ь" Or (j = 2 And l4 = "контр")) Then
                        Rez(i) = Mid(Word, p, j - l + 3): p = j + 4: Exit For
                    End If
                End If
            Next j
            l = l + Len(Rez(i))
        Next i
        Rez(k - 1) = Mid(Word, l + 1)
        If k > 2 Then
            For j = 1 To 2
                For i = 1 To k - 1
                    If Rez(i - 1) = vbNullString Then Rez(i - 1) = Rez(i): Rez(i) = vbNullString
                Next i
            Next j
        End If
        If Len(Rez(k - 1)) = 0 And Len(Rez(k - 2)) = 0 Then
            ReDim Preserve Rez(UBound(Rez) - 2)
        ElseIf Len(Rez(k - 1)) = 0 Then
            ReDim Preserve Rez(UBound(Rez) - 1)
        End If
        If Len(Rez(UBound(Rez))) = 1 Then
            ReDim Preserve Rez(UBound(Rez) - 1)
            If UBound(Rez) = 0 Then Rez(0) = Word Else Rez(UBound(Rez)) = Rez(UBound(Rez)) & Right(Word, 1)
        End If
        If Len(Rez(0)) = 1 Then
            Rez(0) = Rez(0) & Rez(1)
            For i = 1 To UBound(Rez) - 1
                Rez(i) = Rez(i + 1)
            Next i
            ReDim Preserve Rez(UBound(Rez) - 1)
        End If
    End If
    j = UBound(Rez)
    ReDim Preserve Rez(Application.Caller.Columns.Count - 1)
    For i = j + 1 To UBound(Rez)
        Rez(i) = vbNullString
    Next i
    Hyphenation = Rez
End Function
 
Привет!
Правила расстановки переносов придуманы ... к ним теперь
"Азбуку надобно придумать. А то в школе никаких уроков нет, окромясь труда и физкультуры."
Сравнение прайсов, таблиц - без настроек
 
Цитата
Inexsu написал:
Азбуку надобно придумать

По поводу азбуки - это Вам к Кириллу и Мефодию, ко мне - по поводу переносов слов.
Кстати, вот обновлённая версия функции Hyphenation.
Код
Public Function Hyphenation(Word As String) As Variant
    Dim i As Byte, j As Byte, k As Byte, l As Byte, p As Byte
    Dim gl As String, gs As String, sg As String, l1 As String
    Dim l2 As String, l3 As String, l4 As String, l5 As String
    Dim s1 As String, s2 As String, s3 As String, s4 As String
    Application.Volatile
    If Len(Word) < 4 Then Hyphenation = vbNullString: Exit Function
    k = 0: gl = "[аеёиоуыэюя]"
    For i = 1 To Len(Word)
        If Mid(Word, i, 1) Like gl Then k = k + 1
    Next i
    If k = 0 Then Hyphenation = vbNullString: Exit Function
    If k = 1 Then
        ReDim Rez(0) As String
        Rez(0) = Word
    Else
        ReDim Rez(k - 1) As String
        l = 0: p = 1
        l1 = Left(Word, 2): l2 = Left(Word, 3)
        l3 = Left(Word, 4): l4 = Left(Word, 5): l5 = Left(Word, 6)
        gs = "[аеёиоуэюя]": sg = "[бвгджзклмнпрстфхцчшщ]"
        For i = 0 To k - 2
            For j = p To Len(Word) - 1
                s1 = Mid(Word, j, 1): s2 = Mid(Word, j + 1, 1)
                s3 = Mid(Word, j + 2, 1): s4 = Mid(Word, j + 3, 1)
                If s1 Like gl Then
                    If (s2 Like gl And Not (j = 2 And l2 = "наи")) Or (s2 Like sg And s3 = "ь" And s4 Like gs And Not _
                        i = k - 2) Or (s2 Like sg And (s3 Like gl Or Right(Word, 2) Like "ь[еёиюя]") And Not ((j = 3 _
                        And (l1 = "до" Or l1 = "за" Or l1 = "со")) Or ((j = 2 Or j = 4) And (l2 = "без" Or l2 = "воз" Or _
                        l2 = "дез" Or l2 = "меж" Or l2 = "под" Or l2 = "раз" Or l2 = "суб")) Or (j = 4 And (l2 = "вне" Or _
                        l2 = "изо" Or l2 = "наи" Or l2 = "обо" Or l2 = "ото" Or (l2 = "пре" And s2 <> "д") Or l2 = "при" Or _
                        l2 = "про" Or l2 = "адъ" Or l2 = "взъ" Or l2 = "изъ" Or l2 = "инъ" Or l2 = "объ")) Or ((j = 3 Or _
                        j = 5) And (l3 = "пред" Or l3 = "чрез")) Or (j = 5 And (l3 = "анти" Or l3 = "архи" Or l3 = "возо" _
                        Or l3 = "гипо" Or l3 = "недо" Or l3 = "пере" Or l3 = "подо" Or l3 = "дизъ" Or l3 = "конъ" Or _
                        l3 = "межъ" Or l3 = "подъ" Or l3 = "разъ" Or l3 = "субъ")) Or ((j = 4 Or j = 6) And (l4 = "интер" _
                        Or l4 = "гипер" Or l4 = "супер")) Or (j = 6 And (l4 = "возле" Or l4 = "инфра" Or l4 = "около" Or _
                        l4 = "после" Or l4 = "предо" Or l4 = "продо" Or l4 = "прото" Or l4 = "после" Or l4 = "сверх" Or _
                        l4 = "транс" Or l4 = "предъ" Or l4 = "чрезъ")) Or (j = 7 And (l5 = "ультра" Or l5 = "экстра" Or _
                        l5 = "гиперъ" Or l5 = "интеръ" Or l5 = "контръ" Or l5 = "суперъ")) Or (s3 = "ь" And s4 Like sg And _
                        Right(Word, 2) Like "ь[еёиюя]"))) Or (j = 2 And (l1 = "во" Or l1 = "вы" Or l1 = "до" Or l1 = "за" _
                        Or l1 = "не" Or l1 = "по" Or l1 = "ра" Or l1 = "со") And s2 Like "[жс]" And s3 = s2 And s4 Like gl) _
                        Or (((j = 2 And (l1 = "вы" Or l1 = "до" Or l1 = "за" Or l1 = "со")) Or (j = 3 And (l2 = "вне" Or _
                        l2 = "изо" Or l2 = "наи" Or l2 = "обо" Or l2 = "ото" Or (l2 = "пре" And s2 <> "д") Or l2 = "при" _
                        Or l2 = "про")) Or (j = 4 And (l3 = "анти" Or l3 = "архи" Or l3 = "возо" Or l3 = "гипо" Or _
                        l3 = "недо" Or l3 = "пере" Or l3 = "подо")) Or (j = 5 And (l4 = "возле" Or l4 = "инфра" Or _
                        l4 = "около" Or l4 = "после" Or l4 = "предо" Or l4 = "продо" Or l4 = "прото")) Or (j = 6 And _
                        (l5 = "ультра" Or l5 = "экстра"))) And s2 Like sg And s3 Like sg) Then
                        Rez(i) = Mid(Word, p, j - l): p = j + 1: Exit For
                    ElseIf s2 = "й" Or (s2 Like sg And s3 Like sg And Not ((((i = k - 3 Or i = k - 2) _
                        And ((s2 = "д" And s3 = "ж") Or (s2 Like "[дкнсфх]" And s3 = "т") Or (s2 Like "[зн]" _
                        And s3 = "д") Or (s2 = "р" And s3 Like "[гджзпт]") Or (s2 Like "[нс]" And s3 = "к")) _
                        And s4 Like sg) Or s4 = "ь") Or (j = 1 And l2 = "экс") Or (j = 2 And (l3 = "пост" Or _
                        l4 = "контр")) Or (j = 3 And (l4 = "сверх" Or l4 = "транс")))) Or (((j = 2 And _
                        (l2 = "без" Or l2 = "воз" Or l2 = "дез" Or l2 = "меж" Or l2 = "под" Or l2 = "раз" Or _
                        l2 = "суб")) Or (j = 3 And (l3 = "пред" Or l3 = "чрез")) Or (j = 4 And (l4 = "гипер" _
                        Or l4 = "интер" Or l4 = "супер" Or l4 = "через"))) And s3 Like gs) Then
                        Rez(i) = Mid(Word, p, j - l + 1): p = j + 2: Exit For
                    ElseIf (s2 Like sg And s3 Like "[ъь]") Or (s2 Like sg And s3 Like sg And _
                        Not (s4 = "ь" Or (j = 2 And l4 = "контр" And Right(l5, 1) Like sg))) Then
                        Rez(i) = Mid(Word, p, j - l + 2): p = j + 3: Exit For
                    ElseIf s2 Like sg And s3 Like sg And (s4 = "ь" Or (j = 2 And l4 = "контр")) Then
                        Rez(i) = Mid(Word, p, j - l + 3): p = j + 4: Exit For
                    End If
                End If
            Next j
            l = l + Len(Rez(i))
        Next i
        Rez(k - 1) = Mid(Word, l + 1)
        If k > 2 Then
            For j = 1 To 2
                For i = 1 To k - 1
                    If Rez(i - 1) = vbNullString Then Rez(i - 1) = Rez(i): Rez(i) = vbNullString
                Next i
            Next j
        End If
        If Len(Rez(k - 1)) = 0 And Len(Rez(k - 2)) = 0 Then
            ReDim Preserve Rez(UBound(Rez) - 2)
        ElseIf Len(Rez(k - 1)) = 0 Then
            ReDim Preserve Rez(UBound(Rez) - 1)
        End If
        If Len(Rez(UBound(Rez))) = 1 Then
            ReDim Preserve Rez(UBound(Rez) - 1)
            If UBound(Rez) = 0 Then Rez(0) = Word Else Rez(UBound(Rez)) = Rez(UBound(Rez)) & Right(Word, 1)
        End If
        If Len(Rez(0)) = 1 Then
            Rez(0) = Rez(0) & Rez(1)
            For i = 1 To UBound(Rez) - 1
                Rez(i) = Rez(i + 1)
            Next i
            ReDim Preserve Rez(UBound(Rez) - 1)
        End If
    End If
    j = UBound(Rez): k = Application.Caller.Columns.Count - 1
    If j < k Then
        ReDim Preserve Rez(k)
        For i = j + 1 To UBound(Rez)
            Rez(i) = vbNullString
        Next i
    End If
    Hyphenation = Rez
End Function
 
UDF: SymmetricDifference (симметрическая разность двух диапазонов). Аргументы функции - два пересекающихся диапазона Range1 и Range2. Значение функции - текстовая строка, содержащая адреса ячеек нового диапазона, образованного в результате симметрической разности.
    Симметрическая разность двух диапазонов - множественная операция, результатом которой является новый диапазон, включающий все ячейки исходных диапазонов, не принадлежащие одновременно обоим исходным диапазонам. Другими словами, если есть два диапазона Range1 и Range2, их симметрическая разность есть объединение ячеек Range1, не входящих в Range2, с ячейками Range2, не входящими в Range1.

Код
Public Function SymmetricDifference(Range1 As Range, Range2 As Range) As String
    Dim Cell As Range, RangeInt As Range, RangeUni As Range, flag As Boolean
    If Range1.Address = Range2.Address Then Exit Function
    Set RangeInt = Application.Intersect(Range1, Range2)
    If RangeInt Is Nothing Then
        SymmetricDifference = Union(Range1, Range2).Address
        Exit Function
    End If
    For Each Cell In Union(Range1, Range2)
        If Application.Intersect(RangeInt, Cell) Is Nothing Then
            If flag Then
                Set RangeUni = Union(RangeUni, Cell)
            Else
                Set RangeUni = Cell
                flag = True
            End If
        End If
    Next Cell
    SymmetricDifference = RangeUni.Address
End Function
 
Привет!
Для тех, кому сначала нужен range:
Скрытый текст
Сравнение прайсов, таблиц - без настроек
 
Привет!
Inexsu, в 16 строку я б добавил:

Код
If range_Inter Is Nothing Then Set Range_Diff = range_Union: Exit Function
Изменено: Evgenyy - 09.12.2019 20:09:21
 
Цитата
Evgenyy написал:
я б добавил
Добавление проверок в функцию делает её "умной" и затрудняет поиск ошибок.
Я сторонник явных проверок до вызова функции.
Да, в функции App_Union есть проверки, но это я не смог их вынести наружу :-)
Сравнение прайсов, таблиц - без настроек
 
UDF: ModifyShape - изменение автофигур функцией пользователя. Описание в коде функции. Смотрите пример в файле.

Код
Function ModifyShape(ShapeNumber As Byte, ShapeType As Byte, ShapeColor As Long, _
    ShapeLineWeidht As Double, ShapeLineColor As Long, Optional Visibl As Byte = 1)
    '******************************************************************************'
    ' Добавьте фигуру на лист и введите в любую ячейку листа формулу               '
    ' =ModifyShape(ShapeNumber;ShapeType;ShapeColor;ShapeLineWeidht;ShapeLineColor)'
    ' Первый аргумент(ShapeNumber) - номер индекса фигуры от 1 до n,               '
    '                                где n - количество фигур на листе             '
    ' Второй аргумент(ShapeType) - тип фигуры (поддерживаются значения от 1 до 137)'
    ' Третий аргумент(ShapeColor) - цвет фигуры                                    '
    ' Четвёртый аргумент(ShapeLineWeidht) - толщина контурной линии фигуры         '
    ' Пятый аргумент(ShapeLineColor) - цвет контурной линии фигуры                 '
    ' Шестой аргумент(Visibl) - определяет видимость фигуры (0 - ложь,1 - истина)  '
    ' Аргументы могут использовать ссылки на ячейки                                '
    '******************************************************************************'
    With ActiveSheet.Shapes(ShapeNumber)
        .AutoShapeType = ShapeType
        .Fill.ForeColor.RGB = ShapeColor
        .Line.Weight = ShapeLineWeidht
        .Line.ForeColor.RGB = ShapeLineColor
        If Visibl Then .Visible = True Else .Visible = False
    End With
End Function
 
Как функцией пользователя изменить формат и значение любой ячейки.

UDF: ModifyCell (изменение формата и значения ячейки). Первый аргумент (Cell) - ячейка, в которой меняется формат и значение, второй аргумент (Vallue) - значение для записи в ячейку Cell. Смотрите пример в файле.
 
Чем это проще, чем присвоить значение напрямую. Для чего эта функция?
«Бритва Оккама» или «Принцип Калашникова»?
 
Цитата
bedvit написал:
присвоить значение напрямую
Напрямую любой ... сможет присвоить, а вот показать не тривиальное решение не каждому дано.

Цитата
bedvit написал:
Для чего эта функция?
Для саморазвития.
 
Цитата
Evgenyy написал:
Для саморазвития.
так может для саморазвития и под x64 задекларировать, а то не смог ощутить всю мощь и пользу :-)

Сама по себе функция - бред, но методология может куда и сгодится.
По вопросам из тем форума, личку не читаю.
 
Offtop
Цитата
БМВ написал:
так может для саморазвития и под x64 задекларировать,
Саморазвитие в силу обстоятельств ограничено только x32 :)
 
Цитата
БМВ написал:
функция - бред,

Предлагаю ввести новую аббревиатуру: UDNF (User Defined Nonsense Function) - функция-бред определённая пользователем.
UDNF: ModifyCell_2 - изменение формата, значения и размера ячейки пользовательской функцией.
 
Off
Цитата
Evgenyy написал:
UDNF (User Defined Nonsense Function)
Усе уже давно придумано UDSF (User Defined Shit Function) . Только без обид, отношение я выше указал. вот тоже согрешил . Метод - есть, применение - сомнительно.
По вопросам из тем форума, личку не читаю.
 
господа модераторы,
полагаю этой теме самое место в курилке, там одна тема может быть обо всем, что касается работы Excel
Evgenyy, будет вываливать туда свои шедевры, а заинтересованные курильщики будут иметь возможность активно "обкашлять" очередную функцию
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Ігор Гончаренко, я, кстати, только после ваших слов заметил, что она НЕ в Курилке)))
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Цитата
Ігор Гончаренко написал:
полагаю этой теме самое место в курилке
не соглашусь.  Другое дело что обсуждение конкретных проблем делает тему слишком обширной.

Evgenyy, Если уж взялись за такую тему, то в первом сообщении ведите перечень функций с сылками на посты внутри темы, типа оглавления. Польза будет. Такие трюки как последние, которые имеют сомнительный практический смысл, можно выделить в отдельную категорию.
По вопросам из тем форума, личку не читаю.
 
Цитата
Ігор Гончаренко написал:
полагаю этой теме самое место в курилке
Изначально тема называлась "Функции пользователя" и была размещена в "Курилке". Модераторы переименовали тему в "Подборка функций пользователя" и разместили в этой ветке.

Цитата
БМВ написал:
в первом сообщении ведите перечень функций с сылками на посты внутри темы
Хорошая идея, честно говоря никогда не делал ссылки на посты внутри темы. Надо будет изучить этот вопрос, а пока ещё две функции из подборки:

AmountCumulative (сумма нарастающим итогом)
Код
Function AmountCumulative(Cell As Range) As Double
    Dim oldValue As Double, RangeSel As Range
    Application.Volatile
    oldValue = Val(Application.Caller.Text)
    Set RangeSel = Selection
    On Error Resume Next
    If IsError(CDbl(Cell)) Then
        AmountCumulative = oldValue
    ElseIf RangeSel.Address = Cell.Address Then
        AmountCumulative = oldValue + Cell
    Else
        AmountCumulative = oldValue
    End If
End Function

NamesSheets (имена листов рабочей книги)
Код
Function NamesSheets()
    Dim i As Byte, n As Byte, nc As Byte, nr As Byte
    Application.Volatile
    With Application.Caller
        nr = .Rows.Count: nc = .Columns.Count
        If nr > 1 Then n = nr Else n = nc
        ReDim Names(1 To n) As String
        For i = 1 To Application.Min(.Parent.Parent.Sheets.Count, UBound(Names))
            Names(i) = .Parent.Parent.Sheets(i).Name
        Next i
    End With
    If nr > 1 Then NamesSheets = Application.Transpose(Names) Else NamesSheets = Names
End Function


Последние из опубликованных функций: PrimeFactors (разложение натуральных чисел на простые множители); Hyphenation (деление простых слов при переносе); SimmetricDifference (симметрическая разность двух диапазонов); ModifyShape (изменение автофигур функцией пользователя) - в обновлённой подборке UDF10.
Изменено: Evgenyy - 02.01.2020 21:16:08 (обновление ссылки)
 
Цитата
Evgenyy написал:
никогда не делал ссылки на посты внутри темы


#116
Изменено: БМВ - 25.12.2019 12:37:02
По вопросам из тем форума, личку не читаю.
 
UDF: ConcatPrefixNumbers - сцепление чисел с префиксами.
Первый аргумент - диапазон чисел с префиксами, второй - разделитель между числами, третий - разделитель в периодах, четвёртый - сортировка по префиксам по возрастанию ("true" или "false"). Смотрите пример в файле.
Код
Function ConcatPrefixNumbers(DataRange As Range, Optional Delim As String = ", ", _
    Optional Delim2 As String = "-", Optional increase As Boolean = True) As String()
    Dim i As Long, j As Long, k As Long, n As Long
    Dim pref As String, tmp As String, num As Long
    Dim tmpArr() As Variant, datArr() As String, rezArr() As String
    Dim prefArr() As String, numArr() As Long, strArr() As String
    Dim Coll As New Collection
    On Error Resume Next
    tmpArr = DataRange
    ReDim datArr(0)
    ReDim rezArr(0)
    For i = LBound(tmpArr, 1) To UBound(tmpArr, 1)
        For j = LBound(tmpArr, 2) To UBound(tmpArr, 2)
            If Not IsEmpty(tmpArr(i, j)) Then
                datArr(UBound(datArr)) = tmpArr(i, j)
                ReDim Preserve datArr(UBound(datArr) + 1)
            End If
        Next j
    Next i
    ReDim Preserve datArr(UBound(datArr) - 1)
    ReDim prefArr(0)
    For i = LBound(datArr) To UBound(datArr)
        pref = ""
        For j = 1 To Len(datArr(i))
            If Mid(datArr(i), j, 1) Like "[123456789]" Then
                Coll.Add pref, CStr(pref)
                If pref <> "" And Err = 0 Then
                    prefArr(UBound(prefArr)) = pref
                    ReDim Preserve prefArr(UBound(prefArr) + 1)
                Else
                    Err.Clear
                End If
                Exit For
            Else
                pref = pref & Mid(datArr(i), j, 1)
            End If
        Next j
    Next i
    ReDim Preserve prefArr(UBound(prefArr) - 1)
    If increase And UBound(prefArr) > 0 Then
        For i = LBound(prefArr) To UBound(prefArr) - 1
            For j = LBound(prefArr) To UBound(prefArr) - 1 - i
                If prefArr(j) > prefArr(j + 1) Then
                    tmp = prefArr(j)
                    prefArr(j) = prefArr(j + 1)
                    prefArr(j + 1) = tmp
                End If
            Next j
        Next i
    End If
    For i = LBound(prefArr) To UBound(prefArr)
        pref = prefArr(i)
        ReDim numArr(0)
        For j = LBound(datArr) To UBound(datArr)
            tmp = datArr(j)
            If pref = Mid(tmp, 1, Len(pref)) Then
                numArr(UBound(numArr)) = CLng(Mid(tmp, Len(pref) + 1))
                If UBound(numArr) > 0 Then
                    For k = LBound(numArr) + 1 To UBound(numArr)
                        If numArr(UBound(numArr)) = numArr(UBound(numArr) - k) Then GoTo iii
                    Next k
                    ReDim Preserve numArr(UBound(numArr) + 1)
                Else
                    ReDim Preserve numArr(UBound(numArr) + 1)
                End If
            End If
iii:    Next j
        ReDim Preserve numArr(UBound(numArr) - 1)
        For k = LBound(numArr) To UBound(numArr) - 1
            For j = LBound(numArr) To UBound(numArr) - 1 - k
                If numArr(j) > numArr(j + 1) Then
                    num = numArr(j)
                    numArr(j) = numArr(j + 1)
                    numArr(j + 1) = num
                End If
            Next j
        Next k
        ReDim strArr(0)
        For j = LBound(numArr) To UBound(numArr)
            n = 0: num = numArr(j)
            Do While numArr(j) - num - n = 0
                n = n + 1: j = j + 1
                If j > UBound(numArr) Then Exit Do
            Loop
            j = j - 1
            If n = 1 Then
                strArr(UBound(strArr)) = pref & num
            ElseIf n = 2 Then
                strArr(UBound(strArr)) = pref & num
                ReDim Preserve strArr(UBound(strArr) + 1)
                strArr(UBound(strArr)) = pref & numArr(j)
            Else
                strArr(UBound(strArr)) = pref & num & Delim2 & pref & numArr(j)
            End If
            ReDim Preserve strArr(UBound(strArr) + 1)
        Next j
        ReDim Preserve strArr(UBound(strArr) - 1)
        rezArr(UBound(rezArr)) = Join(strArr, Delim)
        ReDim Preserve rezArr(UBound(rezArr) + 1)
        Erase numArr
        Erase strArr
    Next i
    ReDim Preserve rezArr(UBound(rezArr) - 1)
    With Application.Caller.Rows
        If .Count - 1 > UBound(rezArr) Then ReDim Preserve rezArr(.Count - 1)
    End With
    ConcatPrefixNumbers = rezArr
End Function
Изменено: Evgenyy - 07.01.2020 19:05:08
 
UDF: DistanceOnTheSurface - расчёт расстояния между двумя точками на земной поверхности по географическим координатам на основе формул Винсенти.
Формулы Винсенти - это два связанных итерационных метода, используемые в геодезии для вычисления расстояния между двумя точками на поверхности сфероида, разработанные Т. Винсенти.
Оценить точность расчётов можно используя "Калькулятор расстояния и азимута по географическим координатам (референц-эллипсоид WGS-84)". Смотрите пример в файле.

Код
Private Const PI = 3.14159265358979
Private Const low_a As Double = 6378137
Private Const low_b As Double = 6356752.3142
Private Const f As Double = 3.35281066474748E-03
Private Const Epsilon As Double = 0.000000000001

Function DistanceOnTheSurface(latitude1 As Variant, longitude1 As Variant, _
                              latitude2 As Variant, longitude2 As Variant) As Double
    Dim k As Byte, L As Double, U1 As Double, U2 As Double, s As Double
    Dim sinU1 As Double, sinU2 As Double, cosU1 As Double, cosU2 As Double
    Dim iter As Integer, lambda As Double, lambdaP As Double, sigma As Double
    Dim sinLambda As Double, cosLambda As Double, sinSigma As Double, cosSigma As Double
    Dim sinAlpha As Double, cosSqAlpha As Double, cos2SigmaM As Double
    Dim C As Double, uSq As Double, P1 As Double, P2 As Double, P3 As Double
    Dim upper_A As Double, upper_B As Double, deltaSigma As Double
    If Not IsNumeric(latitude1) Or Not IsNumeric(longitude1) _
        Or Not IsNumeric(latitude2) Or Not IsNumeric(longitude2) Then
        Dim tmpArr(1 To 4) As String
        Dim dblArr(1 To 4) As Variant
        tmpArr(1) = latitude1: tmpArr(2) = longitude1
        tmpArr(3) = latitude2: tmpArr(4) = longitude2
        For k = 1 To 4
            dblArr(k) = CFD(tmpArr(k))
            If dblArr(k) = vbNullString Then Exit Function
        Next k
        latitude1 = dblArr(1): longitude1 = dblArr(2)
        latitude2 = dblArr(3): longitude2 = dblArr(4)
    End If
    L = (longitude2 - longitude1) * PI / 180
    U1 = Atn((1 - f) * Tan(latitude1 * PI / 180))
    U2 = Atn((1 - f) * Tan(latitude2 * PI / 180))
    sinU1 = Sin(U1): cosU1 = Cos(U1)
    sinU2 = Sin(U2): cosU2 = Cos(U2)
    lambda = L: lambdaP = 2 * PI
    iter = 100
    Do While (Abs(lambda - lambdaP) > Epsilon) And (iter > 0)
        iter = iter - 1
        sinLambda = Sin(lambda): cosLambda = Cos(lambda)
        sinSigma = Sqr(((cosU2 * sinLambda) ^ 2) + ((cosU1 * sinU2 - sinU1 * cosU2 * cosLambda) ^ 2))
        If sinSigma = 0 Then DistanceOnTheSurface = 0: Exit Function
        cosSigma = sinU1 * sinU2 + cosU1 * cosU2 * cosLambda
        sigma = Atan2(cosSigma, sinSigma)
        sinAlpha = cosU1 * cosU2 * sinLambda / sinSigma
        cosSqAlpha = 1 - sinAlpha * sinAlpha
        If cosSqAlpha = 0 Then cos2SigmaM = 0 Else cos2SigmaM = cosSigma - 2 * sinU1 * sinU2 / cosSqAlpha
        C = f / 16 * cosSqAlpha * (4 + f * (4 - 3 * cosSqAlpha))
        lambdaP = lambda
        P1 = 2 * cos2SigmaM ^ 2 - 1
        P2 = sigma + C * sinSigma * (cos2SigmaM + C * cosSigma * P1)
        lambda = L + (1 - C) * f * sinAlpha * P2
    Loop
    If iter < 1 Then MsgBox "iter = 0": Exit Function
    uSq = cosSqAlpha * (low_a ^ 2 - low_b ^ 2) / (low_b ^ 2)
    P1 = 4096 + uSq * (uSq * (320 - 175 * uSq) - 768)
    upper_A = 1 + uSq / 16384 * P1
    upper_B = uSq / 1024 * (256 + uSq * (uSq * (74 - 47 * uSq) - 128))
    P1 = (4 * sinSigma ^ 2 - 3) * (4 * cos2SigmaM ^ 2 - 3)
    P2 = upper_B * sinSigma
    P3 = cos2SigmaM + upper_B / 4 * (cosSigma * (2 * cos2SigmaM ^ 2 - 1) - upper_B / 6 * cos2SigmaM * P1)
    deltaSigma = P2 * P3
    s = low_b * upper_A * (sigma - deltaSigma) / 1000
    DistanceOnTheSurface = Round(s, 3)
End Function

Private Function CFD(Out As String) As Variant
    Dim Ent As Double, dMi As Double
    If IsNumeric(Out) Then CFD = Out: Exit Function
    Out = Application.Trim(Replace(Replace(Replace(Out, "°", "° "), "'", "' "), ".", ","))
    If IsNumeric(Left(Out, InStr(1, Out, "°") - 1)) And _
        (Right(Out, 6) = "° с,ш," Or Right(Out, 6) = "° в,д,") Then
        Ent = --Mid(Out, 1, Len(Out) - 6)
    ElseIf IsNumeric(Left(Out, InStr(1, Out, "°") - 1)) And _
        (Right(Out, 6) = "° ю,ш," Or Right(Out, 6) = "° з,д,") Then
        Ent = -Mid(Out, 1, Len(Out) - 6)
    ElseIf IsNumeric(Left(Out, InStr(1, Out, "°") - 1)) And _
        (Right(Out, 3) = "° N" Or Right(Out, 3) = "° E") Then
        Ent = --Mid(Out, 1, Len(Out) - 3)
    ElseIf IsNumeric(Left(Out, InStr(1, Out, "°") - 1)) And _
        (Right(Out, 3) = "° S" Or Right(Out, 3) = "° W") Then
        Ent = -Mid(Out, 1, Len(Out) - 3)
    ElseIf Left(Out, 1) Like "[EN]" And Right(Out, 1) = "°" Then
        Ent = --Mid(Out, 2, Len(Out) - 2)
    ElseIf Left(Out, 1) Like "[SW]" And Right(Out, 1) = "°" Then
        Ent = -Mid(Out, 2, Len(Out) - 2)
    ElseIf IsNumeric(Left(Out, InStr(1, Out, "°") - 1)) And Right(Out, 1) = "°" Then
        Ent = --Mid(Out, 1, Len(Out) - 1)
    ElseIf IsNumeric(Left(Out, InStr(1, Out, "°") - 1)) And (Right(Out, 6) = "' с,ш," _
        Or Right(Out, 6) = "' в,д," Or Right(Out, 3) = "' N" Or Right(Out, 3) = "' E") Then
        dMi = --Mid(Out, InStr(1, Out, "°") + 2, InStr(1, Out, "'") - InStr(1, Out, "°") - 2)
        Out = Left(Out, InStr(1, Out, "°") + 1) & Int(dMi) & "' " & Format(((dMi - Int(dMi)) * 60), "0") & Chr(34)
        Ent = ConverterDecimal(Out)
    ElseIf IsNumeric(Left(Out, InStr(1, Out, "°") - 1)) And (Right(Out, 6) = "' ю,ш," _
        Or Right(Out, 6) = "' з,д," Or Right(Out, 3) = "' S" Or Right(Out, 3) = "' W") Then
        dMi = --Mid(Out, InStr(1, Out, "°") + 2, InStr(1, Out, "'") - InStr(1, Out, "°") - 2)
        Out = Left(Out, InStr(1, Out, "°") + 1) & Int(dMi) & "' " & Format(((dMi - Int(dMi)) * 60), "0") & Chr(34)
        Ent = -ConverterDecimal(Out)
    ElseIf (Left(Out, 1) = "N" Or Left(Out, 1) = "E") And Right(Out, 1) = "'" Then
        dMi = --Mid(Out, InStr(1, Out, "°") + 2, Len(Out) - InStr(1, Out, "°") - 2)
        Out = Mid(Out, 2, InStr(1, Out, "°")) & Int(dMi) & "' " & Format(((dMi - Int(dMi)) * 60), "0") & Chr(34)
        Ent = ConverterDecimal(Out)
    ElseIf (Left(Out, 1) = "S" Or Left(Out, 1) = "W") And Right(Out, 1) = "'" Then
        dMi = --Mid(Out, InStr(1, Out, "°") + 2, Len(Out) - InStr(1, Out, "°") - 2)
        Out = Mid(Out, 2, InStr(1, Out, "°")) & Int(dMi) & "' " & Format(((dMi - Int(dMi)) * 60), "0") & Chr(34)
        Ent = -ConverterDecimal(Out)
    ElseIf IsNumeric(Left(Out, InStr(1, Out, "°") - 1)) And Right(Out, 1) = "'" Then
        dMi = --Mid(Out, InStr(1, Out, "°") + 2, Len(Out) - InStr(1, Out, "°") - 2)
        Out = Left(Out, InStr(1, Out, "°") + 1) & Int(dMi) & "' " & Format(((dMi - Int(dMi)) * 60), "0") & Chr(34)
        Ent = ConverterDecimal(Out)
    ElseIf IsNumeric(Left(Out, InStr(1, Out, "°") - 1)) And _
        (Right(Out, 6) = Chr(34) & " с,ш," Or Right(Out, 6) = Chr(34) & " в,д,") Then
        Ent = ConverterDecimal(Mid(Out, 1, Len(Out) - 5))
    ElseIf IsNumeric(Left(Out, InStr(1, Out, "°") - 1)) And _
        (Right(Out, 6) = Chr(34) & " ю,ш," Or Right(Out, 6) = Chr(34) & " з,д,") Then
        Ent = -ConverterDecimal(Mid(Out, 1, Len(Out) - 5))
    ElseIf IsNumeric(Left(Out, InStr(1, Out, "°") - 1)) And _
        (Right(Out, 2) = Chr(34) & "N" Or Right(Out, 2) = Chr(34) & "E") Then
        Ent = ConverterDecimal(Mid(Out, 1, Len(Out) - 1))
    ElseIf IsNumeric(Left(Out, InStr(1, Out, "°") - 1)) And _
        (Right(Out, 2) = Chr(34) & "S" Or Right(Out, 2) = Chr(34) & "W") Then
        Ent = -ConverterDecimal(Mid(Out, 1, Len(Out) - 1))
    ElseIf (Left(Out, 1) = "N" Or Left(Out, 1) = "E") And Right(Out, 1) = Chr(34) Then
        Ent = ConverterDecimal(Mid(Out, 2))
    ElseIf (Left(Out, 1) = "S" Or Left(Out, 1) = "W") And Right(Out, 1) = Chr(34) Then
        Ent = -ConverterDecimal(Mid(Out, 2))
    ElseIf IsNumeric(Left(Out, InStr(1, Out, "°") - 1)) And Right(Out, 1) = Chr(34) Then
        Ent = ConverterDecimal(Out)
    Else
        CFD = vbNullString
        Exit Function
    End If
    CFD = Ent
End Function

Private Function ConverterDecimal(sDegrees As String) As Double
    Dim degrees As Double, minutes As Double, seconds As Double
    degrees = Val(Left(sDegrees, InStr(1, sDegrees, "°") - 1))
    minutes = Val(Mid(sDegrees, InStr(1, sDegrees, "°") + 2, InStr(1, sDegrees, "'") - InStr(1, sDegrees, "°") - 2)) / 60
    seconds = Val(Mid(sDegrees, InStr(1, sDegrees, "'") + 2, Len(sDegrees) - InStr(1, sDegrees, "'") - 2)) / 3600
    ConverterDecimal = degrees + minutes + seconds
End Function

Private Function Atan2(x As Double, y As Double) As Double
    If y > 0 Then
        If x >= y Then
            Atan2 = Atn(y / x)
        ElseIf x <= -y Then
            Atan2 = Atn(y / x) + PI
        Else
            Atan2 = -Atn(x / y) + PI / 2
        End If
    Else
        If x >= -y Then
            Atan2 = Atn(y / x)
        ElseIf x <= y Then
            Atan2 = Atn(y / x) - PI
        Else
            Atan2 = -Atn(x / y) - PI / 2
        End If
    End If
End Function


UDF11 - обновлённая подборка от 22.01.2020 г.
Страницы: Пред. 1 2 3 4 5 6 7 След.
Наверх