Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Выбрать дату в календареВыбрать дату в календаре

Страницы: 1 2 3 4 5 След.
Подборка функций пользователя
 
По мотивам темы "Перевести цифры в химических формулах в подстрочные индексы": функция 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
Сводная таблица с текстом в области значений
 
Где кот? Почему "мышей" не ловит? Загадили весь форум.
Подборка функций пользователя
 
Обновление UDF17.

Добавлены функции:
ConcatViaDelim - сцепление данных через разделитель;
LengthRoute - расчёт протяжённости маршрута по показаниям навигатора;
MaxMinFair - распределение ресурсов между несколькими потребителями.
Подборка функций пользователя
 
Существует проблема разделения дефицитного ресурса среди группы пользователей, каждый из которых имеет равные права на ресурс, но некоторые из них по своей природе требуют меньше ресурсов, чем другие. Как тогда разделить ресурс? Методика совместного использования, широко применимая на практике, называется «Максимальная справедливая доля». Интуитивно понятно, что справедливая доля выделяет пользователю с «малым» спросом то, что он хочет, и равномерно распределяет неиспользуемые ресурсы «крупным» пользователям. Максимальное распределение справедливой доли формально определяют следующим образом:
 –  ресурсы распределяются в порядке возрастания спроса;
 –  ни один пользователь не получает долю ресурса, превышающую его спрос;
 –  пользователи с неудовлетворёнными требованиями получают равную долю ресурса.
Пользовательская функция 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
Подборка функций пользователя
 
Цитата
БМВ написал:
возможно даст сбой
Всё возможно, но у меня сбоев не было. Потестировал на двух машинах с тремя  флешками.
У меня до D: всё занято, свободные только с E: начинаются. Так то поменять с E: на D: это ведь не проблема.
Изменено: Evgenyy - 14 Май 2020 22:42:04
Подборка функций пользователя
 
Цитата
БМВ написал:
GetInfoUSBDrives - судя по всему навеяло темой недавней
Совершенно верно, зародилось в этой теме. Подпитываюсь Вашими идеями.
Подборка функций пользователя
 
Обновление UDF16.

Добавлены функции:
GetInfoType - получение информации о данных;
GetInfoUSBDrives - получение информации о USB-накопителях.
Узнать серийный номер флешки через VBA
 
Посмотрите здесь есть информация по теме.
Извлечение номера телефона из заполненной ячейки, Извлечение номера телефона из заполненной ячейки (доработка макроса)
 
\d
Изменено: Evgenyy - 21 Апр 2020 16:19:18
Извлечение номера телефона из заполненной ячейки, Извлечение номера телефона из заполненной ячейки (доработка макроса)
 
Посмотрите паттерны для извлечения номеров телефонов и электронной почты здесь.
Подборка функций пользователя
 
Цитата
Ігор Гончаренко написал:
отличное название для пользовательской функции
Как говорится: "Слышал звон, но не знаю где он". Для особо непонятливых "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
Подборка функций пользователя
 
Inexsu, спасибо за полезные советы.
В данном листе специально писал с подтормаживанием,  чтобы улучшить визуализацию.
Подборка функций пользователя
 
Функция "ColorTabSheets" - функция для окрашивания ярлыков листов, для заливки ячеек используйте макрос расположенный в коде листа "Оценка цветового контраста".
Правой кнопкой по ярлыку, выбираем "Исходный текст".
Залить ячейку цветом RGB (индексы указаны в трех ячейках)
 
Посмотрите UDF15 - лист "Оценка цветового контраста" и лист "Генерация цвета".
Регулярные выражения - извлечь дату, которые стоит после определенных слов
 
Цитата
Андрей VG написал:
не мешало бы ещё и по допустимым цифрам даты на требуемых позициях ввести ограничение
Когда-то писал регулярку по извлечению дат.
Подборка функций пользователя
 
Обновление UDF15.

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

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

GetArray - преобразование диапазонов и массивов в двумерный массив;
TransposeArray - транспонирование массива (лист "Поворот_и_транспонир._диапазона").
Cуммирование цифр или чисел в одной ячейке
 
Цитата
vikttur написал: макрофункция и UDF - это разные понятия
И понятия разные и функционал. Что Вы будете делать макрофункцией с неразрывными пробелами (или ещё какими-либо символами) между цифрами?

Цитата
buchlotnik написал: не решает поставленную задачу
Почему же не решает. Тема обозначена как "Суммирование цифр в одной ячейке", а не чисел. Модераторы пусть меняют название темы.
Если ТС не различает понятия цифр и чисел - это его проблема.
Изменено: Evgenyy - 5 Апр 2020 18:05:44
Почему сбрасываются глобальные переменные?
 
Цитата
vcomp71 написал: Царь - назваие модуля.
Цитата
Ігор Гончаренко написал: люди высказывают свое мнение,
Мое мнение: назовите модуль "Бред_сивой_кобылы".
Cуммирование цифр или чисел в одной ячейке
 
Цитата
buchlotnik написал:
макрофункцией
Хиленькая макрофункция какая-то.
Так лучше будет:
Код
Function SumDigits(x As Variant) As Long
    Dim n As Long, Symbol As String
    For n = 1 To Len(CStr(x))
        Symbol = Mid(x, n, 1)
        If Symbol Like "#" Then SumDigits = SumDigits + CLng(Symbol)
    Next n
End Function
Оптические иллюзии в Excel
 
Цитата
Юрий М написал:
он и не такие оптические иллюзии наблюдает
Изменено: Evgenyy - 26 Мар 2020 18:05:44
Оптические иллюзии в Excel
 
Медведю не угодишь! А всё от того, что питается рисом, а не гречкой.
Цитата
БМВ написал:
непонятно - почему в одной пачке риса 30078 штучек риса, а в другой 30012?
Оптические иллюзии в Excel
 
Цитата
БМВ написал:
это можно описать и закодить
Только где эти "писатели" и "кодеры"? На основном форуме сайта порядка 20-ти человек из 98 000 зарегистрированных предлагают что-то полезное, стоящее и реально помогают. О каком писательстве можно говорить при такой статистике?

Цитата
БМВ написал:
какой смысл от этой функции?
Перефразирую: "Кому это надо?". Прежде всего, это надо мне. Я экспериментирую, делаю что-то, может быть и бессмысленное, но интересное. Со своими идеями и разработками я делюсь со всеми пользователями. Вы предлагаете "закрыться" и не публиковать свои "безумные" идеи?
Изменено: Evgenyy - 21 Мар 2020 18:32:10
Оптические иллюзии в Excel
 
Оптические иллюзии в Excel можно создавать с помощью автофигур. Управлять автофигурами (изменять размеры и цвет, поворачивать в пространстве и пр.) можно используя функцию пользователя. Отсюда вывод: возможно создание оптических иллюзий функцией пользователя.
UDF: DrawIllusions - функция создания оптических иллюзий. Один аргумент - номер иллюзии от 1 до 9. Очистка листа от автофигур - аргумент "0". Зарождение темы здесь. Смотрите иллюзии в файле.
Изменено: Evgenyy - 20 Мар 2020 18:51:39
Подборка функций пользователя
 
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 Мар 2020 19:01:14
Подборка функций пользователя
 
Цитата
bedvit написал:
корни  отсюда
Совершенно верно. Хорошая идея.
Изменено: Evgenyy - 3 Мар 2020 20:47:41
Подборка функций пользователя
 
Обновление UDF14.

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

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

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

Почистил код в книге от мусора, что позволило сократить размер книги на 10%. Обсуждение инструментов и методов очистки в этой теме.
Полное (расширенное) сравнение двух списков (столбцов)
 
Цитата
Jack Famous написал:
что вам оказалось не полезно?
Цитата
Alemox написал:
если честно взрыв мозга. Зачем так усложнять.  
Полное (расширенное) сравнение двух списков (столбцов)
 
Не сочтите за обиду, но я абсолютно согласен с Alemox.
Причины изменения размера файла vbaProject.bin
 
Поэкспериментировал с надстройкой, и пришёл к выводу: надстройка чистит код только в модулях, но не в листах книги.
На основании чего сделал такой вывод? На основании того, что после очистки кода надстройкой, методом описанным в #1 очистил код ещё на 10 Кб.
Изменено: Evgenyy - 2 Мар 2020 18:14:06
Страницы: 1 2 3 4 5 След.
Наверх