Страницы: Пред. 1 2 3 4 5 6 7 След.
RSS
Подборка функций пользователя
 
UDF: RotorShape - вращение автофигур функцией пользователя. Описание в коде функции. Смотрите пример в файле.

Код
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Function RotorShape(ShapeNumber As Byte, Optional rotor As Integer = 1, _
    Optional speed As Byte = 10, Optional clockwise As Boolean = True, _
    Optional rotorX As Boolean = True, Optional rotorY As Boolean = True, _
    Optional rotorZ As Boolean = True)
    '---------------------------------------------------------------------'
    ' Первый аргумент(ShapeNumber) - номер индекса фигуры                 '
    ' Второй аргумент(rotor) - количество оборотов фигуры                 '
    ' Третий аргумент(speed) - скорость вращения фигуры (от 1 до 50)      '
    ' Четвёртый аргумент(clockwise) - направление вращения,               '
    '   по часовой [ИСТИНА(1)] или против часовой [ЛОЖЬ(0)]               '
    ' Пятый аргумент(rotorX) - вращение вокруг оси X [ИСТИНА(1),ЛОЖЬ(0)]  '
    ' Шестой аргумент(rotorY) - вращение вокруг оси Y [ИСТИНА(1),ЛОЖЬ(0)] '
    ' Седьмой аргумент(rotorZ) - вращение вокруг оси Z [ИСТИНА(1),ЛОЖЬ(0)]'
    '---------------------------------------------------------------------'
    Dim i As Integer, j As Integer, k As Integer, delay As Long
    Application.Volatile
    If Not rotorX And Not rotorY And Not rotorZ Then Exit Function
    delay = Int(500 / speed)
    If delay < 10 Then delay = 10
    If clockwise Then k = 1 Else k = -1
    For j = 1 To rotor
        For i = 10 * k To 360 * k Step 10 * k
            With ActiveSheet.Shapes.Range(Array(ShapeNumber)).ThreeD
                If rotorX Then .RotationX = i
                If rotorY Then .RotationY = i
                If rotorZ Then .RotationZ = i
            End With
            Sleep delay
            DoEvents
        Next i
    Next j
    RotorShape = ""
End Function
 
Обновление UDF12.

Добавлены функции:
ColorTabSheets - изменение цвета ярлыков листов рабочей книги функцией пользователя (лист "Оценка цветового контраста");
NamesProcedures - создание списка процедур VBA проекта рабочей книги (лист "Списки имён листов и процедур");
RevolveShape - вращение автофигур функцией пользователя;
RotateRange - поворот диапазона на 90 градусов;
SearchPrime - поиск простых чисел;
SortFunc - сортировка диапазона функцией пользователя;
Subtitutes - множественная замена символов в тексте;
SumSkip - суммирование с пропуском строк или столбцов;
WriteMassa2 - пропись массы, тонны и килограммы прописью.
 
Evgenyy, Evgenyy, Как говорится, взялся ……   Декларировать для x64 кто будет?  :D
По вопросам из тем форума, личку не читаю.
 
Цитата
БМВ написал:
Декларировать для x64 кто будет?
Возможно в следующем обновлении.
 
Обновление UDF14.

Добавлены функции:
GenerateRGBColor - генерация цвета в заданном диапазоне R+G+B (лист "Генерация цвета");
PropertiesShape - значения свойств автофигур (лист "Изменение автофигур функцией");

три короткие (шорт) функции, количество строк кода которых не более 10:
CountUnique - подсчёт количества уникальных значений в ячейке;
ExtractUnique3 - извлечение уникальных значений из диапазона;
SumDigits - сумма цифр в ячейке (лист "Шорт функции");

три гиперболические (Sch, Csch, Cth) и три обратные гиперболические (Arsch, Arcsch, Arcth) функции (лист "Гиперболические функции").

Почистил код в книге от мусора, что позволило сократить размер книги на 10%. Обсуждение инструментов и методов очистки в этой теме.
 
GenerateRGBColor корни отсюда
«Бритва Оккама» или «Принцип Калашникова»?
 
Цитата
bedvit написал:
корни  отсюда
Совершенно верно. Хорошая идея.
Изменено: Evgenyy - 03.03.2020 20:47:41
 
UDF: DrawIllusion - создание оптической иллюзии переплетения функцией пользователя.

Ещё больше иллюзий здесь!

Код
Option Explicit
Const PI As Double = 3.14159265358979

Function DrawIllusion(Optional nColor As Long = 9868950, Optional nRot As Integer = 1) As String
    Dim Shp As Shape, i As Byte, j As Byte, r As Byte, x As Double, y As Double
    Dim angle As Double, numDraw As Byte, numSq As Byte
    Dim rot As Integer, rotOffset As Integer, color As Long
    For Each Shp In ActiveSheet.Shapes
        If Shp.Name <> "Button 1" Then Shp.Delete
    Next
    Set Shp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 0, 0, 420, 420)
    With Shp
        .Rotation = 0
        .Line.Weight = 1
        .Line.ForeColor.RGB = vbWhite
        .Fill.ForeColor.RGB = nColor
    End With
    For i = 1 To 4
        r = 60 + (i - 1) * 40
        numDraw = Int(PI * r / 10)
        numSq = numDraw - numDraw Mod 2
        rotOffset = (-20 + (i Mod 2) * 40) * nRot
        For j = 1 To numSq
            x = 200: y = 200
            angle = (j - 1) * 2 * PI / numSq
            x = x + r * Cos(angle)
            y = y + r * Sin(angle)
            rot = angle * 180 / PI
            color = IIf(j Mod 2 = 1, vbBlack, vbWhite)
            Set Shp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, x, y, 15, 15)
            With Shp
                .Rotation = rot + rotOffset
                .Line.Weight = 1
                .Line.ForeColor.RGB = color
                .Fill.ForeColor.RGB = nColor
            End With
        Next j
    Next i
    DrawIllusion = vbNullString
End Function
Изменено: Evgenyy - 20.03.2020 19:01:14
 
Обновление UDF15.

Добавлены функции:
DrawIllusions - создание оптических иллюзий функцией пользователя,
один аргумент - порядковый номер иллюзии (от 1 до 9) (лист "Оптические_иллюзии");

ConvertToLetter - преобразование номеров столбцов в заголовки;
ListAddIns - создание списка доступных/установленных надстроек;
SigFig - округление чисел до заданного количества значащих цифр (лист "Шорт_функции");

GetArray - преобразование диапазонов и массивов в двумерный массив;
TransposeArray - транспонирование массива (лист "Поворот_и_транспонир._диапазона").
 
Привет!
Хорошая работа!
Чуть более быстрый вариант "Оценка_цветового_контраста":
Скрытый текст
Сравнение прайсов, таблиц - без настроек
 
Добрый вечер! Не поможете с функцией ColorTabSheets? Я не могу ею воспользоваться, точнее говоря не понимаю, я прочитал код
Код
Function ColorTabSheets(Optional nColor As Long = 14336204)
    Dim Sheet As Worksheet
    Application.Volatile False
    ColorTabSheets = ""
    If nColor > 16777215 Then Exit Function
    For Each Sheet In ActiveWorkbook.Worksheets
        With Sheet.Tab
            If nColor = 0 Then .TintAndShade = 1 Else .Color = nColor
        End With
    Next Sheet
End Function

Я не понимаю, как в самом Excel писать, чтобы у меня ячейка залилась!
К примеру у меня числа 100 110 120
=ColorTabSheets() как писать?
Изменено: aselliseu - 19.04.2020 21:09:31
 
Функция "ColorTabSheets" - функция для окрашивания ярлыков листов, для заливки ячеек используйте макрос расположенный в коде листа "Оценка цветового контраста".
Правой кнопкой по ярлыку, выбираем "Исходный текст".
 
Inexsu, спасибо за полезные советы.
В данном листе специально писал с подтормаживанием,  чтобы улучшить визуализацию.
 
Извините, всё равно не понимаю! В UDF12 в исходном коде не показано как надо записывать! Прошу помогите
 
Как-то так:
Код
Private Sub Worksheet_Calculate()
    Dim Cell As Range
    For Each Cell In Range("Диапазон")
        With Cell
            .Interior.Color = RGB(.Offset(0, -6), .Offset(0, -5), .Offset(0, -4))
        End With
    Next Cell
End Sub
 
Цитата
aselliseu написал:
UDF12
отличное название для пользовательской функции по нему любому пользователю сразу становится ясно для чего нужна эта функция, особенно, когда UDF12 лежит в большой библиотеке с "подборкой функций пользователя", как заявлено в теме
Изменено: Ігор Гончаренко - 19.04.2020 21:39:24
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Цитата
Ігор Гончаренко написал:
отличное название для пользовательской функции
Как говорится: "Слышал звон, но не знаю где он". Для особо непонятливых "UDF12" и т.д. - не функции, а файлы!
 
Обновление UDF16.

Добавлены функции:
GetInfoType - получение информации о данных;
GetInfoUSBDrives - получение информации о USB-накопителях.
 
Evgenyy,GetInfoUSBDrives - судя по всему навеяло темой недавней, но я на досуге подумал, если нестандартно отформатировать на несколько разделов, это редкость но возможность есть, то возможно даст сбой и возможно по моей вине, так как я убрал один запрос, переход от патиции к физическому диску. Как будет при нескольких патициях я сказать не могу.  
По вопросам из тем форума, личку не читаю.
 
Цитата
БМВ написал:
GetInfoUSBDrives - судя по всему навеяло темой недавней
Совершенно верно, зародилось в этой теме. Подпитываюсь Вашими идеями.
 
Цитата
Evgenyy написал:
Подпитываюсь Вашими идеями.
да не в этом дело, я опасаюсь что идея со сбоем.

Проверил, серийный определяется нормально, а вот почему драйвы с литеры E: у Вас? Е мен D: E:  патиции этой флэхи,  
Изменено: БМВ - 14.05.2020 22:31:09
По вопросам из тем форума, личку не читаю.
 
Цитата
БМВ написал:
возможно даст сбой
Всё возможно, но у меня сбоев не было. Потестировал на двух машинах с тремя  флешками.
У меня до D: всё занято, свободные только с E: начинаются. Так то поменять с E: на D: это ведь не проблема.
Изменено: Evgenyy - 14.05.2020 22:42:04
 
Цитата
Evgenyy написал:
Потестировал на двух машинах с тремя  флешками.
не внимательно читали. Я о нескольких патициях на одном драйве писал
DISKPART> list disk

 Disk ###  Status         Size     Free     Dyn  Gpt
 --------  -------------  -------  -------  ---  ---
 Disk 0    Online          476 GB  1024 KB
 Disk 1    Online         7651 MB  1024 KB

DISKPART> select disk 1

Disk 1 is now the selected disk.

DISKPART> list partition

 Partition ###  Type              Size     Offset
 -------------  ----------------  -------  -------
 Partition 1    Primary           4000 MB  1024 KB
 Partition 2    Primary           3649 MB  4001 MB

но все обошлось.
По вопросам из тем форума, личку не читаю.
 
Здравствуйте. Часто случается, что в пользовательских функциях, которые написал кто-то другой, не знаешь какой параметр нужно ввести, особенно если функцией редко пользуешься, хотя эти функции являются даже очень хорошими. Так почему бы создателям этих функций или тому кто делает подобные сборники не описать их с помощью не хитрого макроса? Ведь у большинства пользователей версия Excel выше 2007. С помощью такого описания думаю было бы на много легче ориентироваться в чужой функции. Вот пример кода:
Код
Sub SpecifyDescriptions()
    Dim D0 As String, D1 As String, D2 As String, D3 As String, D4 As String, D5 As String
        D0 = "Возвращает слово по порядковому номеру или часть строки"
        D1 = "— ячейка, [обьязательный]"
        D2 = "— пробел по умолчанию,[не обьязательный]"
        D3 = "— по умолчанию 1-е слово, номерация слева на право,[не обьязательный]"
        D4 = "— по умолчанию разделяются все слова,[не обьязательный]"
        D5 = "— по умолчанию 0, функция чувствительна к регистру, [не обьязательный]"
        Application.MacroOptions _
            Macro:="РАЗДЕЛСТРОКИ", _
            Description:=D0, _
            Category:=7, _
            ArgumentDescriptions:=Array(D1, D2, D3, D4, D5)
End Sub
Изменено: Niko.x87 - 14.05.2020 23:06:32
 
Существует проблема разделения дефицитного ресурса среди группы пользователей, каждый из которых имеет равные права на ресурс, но некоторые из них по своей природе требуют меньше ресурсов, чем другие. Как тогда разделить ресурс? Методика совместного использования, широко применимая на практике, называется «Максимальная справедливая доля». Интуитивно понятно, что справедливая доля выделяет пользователю с «малым» спросом то, что он хочет, и равномерно распределяет неиспользуемые ресурсы «крупным» пользователям. Максимальное распределение справедливой доли формально определяют следующим образом:
 –  ресурсы распределяются в порядке возрастания спроса;
 –  ни один пользователь не получает долю ресурса, превышающую его спрос;
 –  пользователи с неудовлетворёнными требованиями получают равную долю ресурса.
Пользовательская функция MaxMinFair - функция справедливого распределения ресурсов между несколькими требованиями. Первый аргумент - диапазон с требованиями, второй - количество ресурса.

Код
Function MaxMinFair(DataRange As Variant, Supply As Double) As Variant
    Dim i As Long, n As Long, u As Long
    Dim Allocated() As Double, Available As Double, Share As Double
    If TypeName(DataRange) = "Range" Then DataRange = DataRange.Value2
    If Supply <= 0 Or UBound(DataRange, 2) > 1 Then Exit Function
    u = UBound(DataRange, 1)
    For i = 1 To u
        If DataRange(i, 1) < 0 Then
            Exit Function
        ElseIf DataRange(i, 1) > 0 Then
            n = n + 1
        End If
    Next i
    Available = Supply
    ReDim Allocated(1 To u, 1 To 1)
    Do Until n = 0 Or Available = 0
        Share = Available / n
        n = 0:  Available = 0
        For i = 1 To u
            If Allocated(i, 1) < DataRange(i, 1) Then Allocated(i, 1) = Allocated(i, 1) + Share
        Next i
        For i = 1 To u
            If Allocated(i, 1) >= DataRange(i, 1) Then
                Available = Available + Allocated(i, 1) - DataRange(i, 1)
                Allocated(i, 1) = DataRange(i, 1)
            Else
                n = n + 1
            End If
        Next i
    Loop
    MaxMinFair = Allocated
End Function
 
Обновление UDF17.

Добавлены функции:
ConcatViaDelim - сцепление данных через разделитель;
LengthRoute - расчёт протяжённости маршрута по показаниям навигатора;
MaxMinFair - распределение ресурсов между несколькими потребителями.
 
По мотивам темы "Перевести цифры в химических формулах в подстрочные индексы": функция SubscriptsInChemicalEquations - подстрочные индексы в уравнениях химических реакций. Смотрите примеры в файле.

Код
Function SubscriptsInChemicalEquations(Out As String) As String
    Dim i As Byte, j As Byte, lenOut As Byte, Ent As String, Symb As String, Symbol As String
    lenOut = Len(Out)
    If lenOut < 2 Then Exit Function
    For i = 2 To lenOut
        Symbol = Mid(Out, i, 1)
        Symb = Mid(Out, i - 1, 1)
        If Symbol Like "[1-9]" And (Symb Like "[a-yB-Y)]" Or Symb = "]") Then
            Ent = Ent & ChrW(CLng(Symbol) + 8320)
            If i < lenOut Then
                For j = i + 1 To lenOut
                    Symbol = Mid(Out, j, 1)
                    If Symbol Like "#" Then Ent = Ent & ChrW(CLng(Symbol) + 8320): i = i + 1 Else Exit For
                Next j
            End If
        Else
            Ent = Ent & Symbol
        End If
    Next i
    SubscriptsInChemicalEquations = Mid(Out, 1, 1) & Ent
End Function
 
Обновление Library_UDF.

Добавлены функции:
PolygonArea - расчёт площади простого многоугольника по координатам вершин;
SubscriptsInChemicalEquations - подстрочные индексы в уравнениях химических реакций.
Изменено: Evgenyy - 25.09.2020 22:58:39
 
Билинейная интерполяция - обобщение линейной интерполяции одной переменной для функций двух переменных. Обобщение основано на применении обычной линейной интерполяции сначала в направлении одной из координат, а затем в перпендикулярном направлении. Функция билинейной интерполяции BilingualInterpolation интерполирует значения исходной функции двух переменных в произвольном прямоугольнике по четырём её значениям в вершинах прямоугольника. Аргументы функции: значение х, значение у, диапазон со значениями исходной функции, точность округления.

Код
Function BilingualInterpolation(x As Double, y As Double, DataRange As Range, Optional Rank As Byte = 3) As Variant
    Dim n() As Variant, i As Long, j As Long, u1 As Long, u2 As Long, Rez As Double
    n = DataRange.Value2
    u1 = UBound(n, 1): u2 = UBound(n, 2)
    If x < n(1, 2) Or x > n(1, u2) Or y < n(2, 1) Or y > n(u1, 1) Then BilingualInterpolation = "-": Exit Function
    For i = 3 To u2
        If x <= n(1, i) Then Exit For
    Next i
    For j = 3 To u1
        If y <= n(j, 1) Then Exit For
    Next j
    Rez = ((n(j - 1, i - 1) * (n(1, i) - x) + n(j - 1, i) * (x - n(1, i - 1))) * (n(j, 1) - y) _
          + (n(j, i - 1) * (n(1, i) - x) + n(j, i) * (x - n(1, i - 1))) * (y - n(j - 1, 1))) / _
          ((n(1, i) - n(1, i - 1)) * (n(j, 1) - n(j - 1, 1)))
    BilingualInterpolation = Round(Rez, Rank)
End Function
Изменено: Evgenyy - 19.09.2020 21:43:25
 
Обновление Library_UDF.

Добавлены функции:
BilingualInterpolation - билинейная интерполяция;
CircleCenter - расчёт радиуса и координат центра окружности, описанной вокруг трёх точек в пространстве.

Добавлена кнопка просмотра иллюзий на лист "Оптические иллюзии" (время просмотра 2 мин. 15 сек.).
Страницы: Пред. 1 2 3 4 5 6 7 След.
Наверх