Страницы: Пред. 1 2
RSS
UDF для конвертации персидской даты в григорианскую
 
Сейчас подкину пару задач. :)  
Изменено: sokol92 - 01.04.2020 13:57:04
Владимир
 
БМВ, добавил MinLen As Integer, теперь всё работает, во всяком случае, я не нашёл, как заглючить.
Спасибо!  
Изменено: Acid Burn - 01.04.2020 14:17:35
 
Acid Burn, для конретного случая можно синтезировать вариант из моего и Владимира. Я делал функцию которая найдет месяц из строки даже если там есть что-то лишнее. Владимир же передает в нее только название месяца и тогда можно просто сравнивать.
Код
Function GetMonth(ByVal strDate As String) As Integer
Dim i as integer
For i = 1 To 12
    If StrComp(strDate, WorksheetFunction.Text(DateSerial(1900, i, 1), "[$-160429]mmmm"), vbTextCompare) = 0 Then
        GetMonth = 1 + ((i + 8) Mod 12)
    Exit For
    End If
Next
End Function
По вопросам из тем форума, личку не читаю.
 
БМВ, последняя функция вроде быстрее на большом массиве данных. Благодарю!
 
Если нужна скорость, то кеш:
Код
Function GetMonth(ByVal strDate As String) As Integer
    Dim i As Integer
    Static arr(1 To 12) As String
    If arr(1) = "" Then
        For i = 1 To 12
            arr(1 + (i + 8) Mod 12) = WorksheetFunction.Text(DateSerial(1900, i, 1), "[$-160429]mmmm")
        Next i
    End If
  
    For i = 1 To 12
        If StrComp(strDate, arr(i), vbTextCompare) = 0 Then
            GetMonth = i
            Exit For
        End If
    Next i
End Function
Изменено: sokol92 - 01.04.2020 15:01:02
Владимир
 
sokol92, вообще красота. Надеюсь, на этом тема закрыта. Спасибо!!!
 
Цитата
Acid Burn написал:
Надеюсь, на этом тема закрыта.
Ну да, конечно  :D
Код
Function GetMonth(ByVal strDate As String) As Integer
Dim i As Integer
Static StrArr(1 To 12) As String
If StrArr(1) = "" Then
    arrm = Array( _
        1601, 1585, 1608, 1585, 1583, 1740, 1606, 0, _
        1575, 1585, 1583, 1740, 1576, 1607, 1588, 1578, _
        1582, 1585, 1583, 1575, 1583, 0, 0, 0, _
        1578, 1740, 1585, 0, 0, 0, 0, 0, _
        1605, 1585, 1583, 1575, 1583, 0, 0, 0, _
        1588, 1607, 1585, 1740, 1608, 1585, 0, 0, _
        1605, 1607, 1585, 0, 0, 0, 0, 0, _
        1570, 1576, 1575, 1606, 0, 0, 0, 0, _
        1570, 1584, 1585, 0, 0, 0, 0, 0, _
        1583, 1740, 0, 0, 0, 0, 0, 0, _
        1576, 1607, 1605, 1606, 0, 0, 0, 0, _
        1575, 1587, 1601, 1606, 1583, 0, 0, 0)
    
    For i = 1 To 12
        For j = 1 To 8
            If arrm(i * 8 - 9 + j) <> 0 Then StrArr(i) = StrArr(i) & ChrW(arrm(i * 8 - 9 + j))
        Next
    Next
End If

For i = 1 To 12
    If StrComp(strDate, StrArr(i), vbTextCompare) = 0 Then
        GetMonth = i
    Exit For
    End If
Next
End Function
По вопросам из тем форума, личку не читаю.
 
Я подобный трюк тоже использую на небольших объемах. Еще одно  преимущество - враг не догадается, робот по тексту не найдет. :D  
Изменено: sokol92 - 01.04.2020 16:33:21
Владимир
 
БМВ, а в чём плюсы новой версии GetMonth, кроме указанных sokol92?
 
Пока Михаил самоизолировался - рискну ответить. Главный плюс - будет работать для всех версий Excel при любых региональных настройках.
Владимир
 
Не знаю, будет ли быстрее или наоборот.
Код
Function GetMonth(ByVal strDate As String) As Integer
Dim i As Integer
Static StrArr(1 To 12) As String
If StrArr(1) = "" Then
    arrm = Array( _
        Array(1601, 1585, 1608, 1585, 1583, 1740, 1606), _
        Array(1575, 1585, 1583, 1740, 1576, 1607, 1588, 1578), _
        Array(1582, 1585, 1583, 1575, 1583), _
        Array(1578, 1740, 1585), _
        Array(1605, 1585, 1583, 1575, 1583), _
        Array(1588, 1607, 1585, 1740, 1608, 1585), _
        Array(1605, 1607, 1585), _
        Array(1570, 1576, 1575, 1606), _
        Array(1570, 1584, 1585), _
        Array(1583, 1740), _
        Array(1576, 1607, 1605, 1606), _
        Array(1575, 1587, 1601, 1606, 1583))
    
    For i = 1 To 12
        For j = 0 To UBound(arrm(i - 1))
            StrArr(i) = StrArr(i) & ChrW(arrm(i - 1)(j))
        Next
    Next
End If

For i = 1 To 12
    If StrComp(strDate, StrArr(i), vbTextCompare) = 0 Then
        GetMonth = i
    Exit For
    End If
Next
End Function
По вопросам из тем форума, личку не читаю.
 
Цитата
sokol92 написал:
будет работать для всех версий Excel при любых региональных настройках.
все верно. Мое мнение, что решение в excel должно быть самодостаточным и любая функция, что в надстройке или персональной книге - это зло. Да простят меня писатели подобных надстроек. Обратная совместимость и совместимость с различными региональными настройками , а также с Mac версией, должна быть максимальна.
Предыдущая версия не работала в 2007 и хоть он и не поддерживается больше, но люди с 2003 еще не слезли.
По вопросам из тем форума, личку не читаю.
 
Поскольку заполнение массива производится однократно, выяснить скорость вряд ли удастся - не хватит точности измерений. С моей точки зрения, последний вариант удобнее, именно так и генерируем код в случае необходимости. В других аналогичных офисных пакетах такой проблемы нет, так как всё хранится в UTF-8.
Владимир
 
Ну что же, значит must have. Заменил, всё работает. Большое человеческое спасибо!
 
Подтверждаю - и у меня на 2010 взлетело правильно.
P.S. и рад что помогло https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=127110&TITLE_SEO=127110-udf-dlya-konvertatsii-persidskoy-daty-v-grigorianskuyu&MID=1047450&buf_fid=1#message1047450
Изменено: Hugo - 01.04.2020 19:11:26
 
Hugo,  Я ради кого все это затеял?  :) Не мог же я оставить уважаемого форумчанина без персидского календаря  :D
По вопросам из тем форума, личку не читаю.
 
Не, всё правильно. Теперь у нас есть такая UDF, и может только у нас и есть - я поискал вчера в сети, ничего такого не нашёл.
 
Игорь, я думаю искать нужно в той локации или на том языке. Просто есть вот такие ветки https://www.excelforum.com/non-english-excel/ которые  для многих ни о чем не скажут, а может там все есть.

P.S. мне не помогло, я сперва все сгенерил, а потом заметил :-) , но формулисту решение с форматом было ближе, так что это я так для самоизоляции, тьфу ты , короче сегодня и так не скучно было, а тут еще и задача с практическим применением.
Изменено: БМВ - 01.04.2020 19:23:34
По вопросам из тем форума, личку не читаю.
Страницы: Пред. 1 2
Наверх