Страницы: 1 2 След.
RSS
UDF для конвертации персидской даты в григорианскую
 
Доброго времени!

Нужна Ваша помощь с написанием UDF для конвертации персидской даты в григорианскую. Точнее надо заменить функцию
Код
toGregorianDateObject(jy As Long, jm As Long, jd As Long) на GDate(Cell)
, где Cell - ссылка на ячейку.
С уважением.

Во вложении финальная версия файла. Всем спасибо!
Изменено: Acid Burn - 04.06.2023 15:35:36 (Добавлена функция Pers2Greg)
 
Доброй ночи!
Думаю кроме того что там всё довольно запутано, проблема в том что в коде не получится легко прописать эти персидские символы.
Наверное есть смысл поискать что-то другое уже готовое, должно ведь быть!
 
Цитата
Hugo написал:
не получится легко прописать эти персидские символы
Как раз потому, что прописать не получилось, я и обратился за помощью... Должен быть какой-то вариант прописать, готового ничего не нашёл...
 
Если вопрос только как прописать - можно пробовать символы подбирать кодами Chrw(), но там ещё какой-то синтаксис мудрёный...
 
Получилось вывести содержимое ячейки в MsgBox:
Код
Option Explicit
#If Win64 Then
    Private Declare PtrSafe Function User32MsgBox Lib "user32" Alias "MessageBoxW" (Optional ByVal hWnd As Long, Optional ByVal Prompt As Long, Optional ByVal Title As Long, Optional ByVal Buttons As Long) As Long
#Else
    Private Declare Function User32MsgBox Lib "user32" Alias "MessageBoxW" (Optional ByVal hWnd As Long, Optional ByVal Prompt As Long, Optional ByVal Title As Long, Optional ByVal Buttons As Long) As Long
#End If

Public Function MessageBoxW(cPrompt As String, Optional cButtons As VbMsgBoxStyle = vbOKOnly, Optional cTitle As String) As Long
    MessageBoxW = User32MsgBox(0, StrPtr(cPrompt), StrPtr(cTitle), cButtons)
End Function

Sub Test()
    MessageBoxW Sheets("ДАТЫ").Cells(2, 3).Value
End Sub
Других идей пока нет, до завтра...
Изменено: Acid Burn - 31.03.2020 02:07:03
 
Может поможет?
Код
Sub tt()
    Dim r As Range, t$, s$, i&
    For Each r In [f2:f13]
        t = r.Value
        MessageBoxW t
        s = ""
        For i = 1 To Len(t)
            'MessageBoxW Mid(t, i, 1)
            'Debug.Print AscW(Mid(t, i, 1))
            s = s & "|" & AscW(Mid(t, i, 1))
        Next
        Debug.Print r(1, 2); Mid(s, 2)
    Next
End Sub

1 1601|1585|1608|1585|1583|1740|1606
2 1575|1585|1583|1740|1576|1607|1588|1578
3 1582|1585|1583|1575|1583
4 1578|1740|1585
5 1605|1585|1583|1575|1583
6 1588|1607|1585|1740|1608|1585
7 1605|1607|1585
8 1570|1576|1575|1606
9 1570|1584|1585
10 1583|1740
11 1576|1607|1605|1606
12 1575|1587|1601|1606|1583
Изменено: Hugo - 31.03.2020 02:11:42
 
Восток дело тонкое!
Попробовал переводчиком перевести список месяцев
فروردین1апреля
اردیبهشت2может
خرداد3июнь
تیر4Стрелка
مرداد5августейший
شهریور6сентябрь
مهر7печать
آبان8ноябрь
آذر9декабрь
دی10январь
بهمن11лавина
اسفند12марш
тот же переводчик даёт перевод
январьژانویه
февральفوریه
мартراهپیمایی
апрельآپریل
майممکن است
июньژوئن
июльژوئیه
августاوت
сентябрьسپتامبر
октябрьاکتبر
ноябрьنوامبر
декабрьدسامبر
Изменено: Александр Моторин - 31.03.2020 06:54:53
 
Переводчики тут не помогут - лучше использовать таблицу [F2:G13], которую надо "спрятать" в UDF. В [С3] есть готовая формула, написанная на скорую руку, но всё же рабочая. Есть Sub Test() и Sub tt(). Вроде всего достаточно, но синтезировать готовую UDF пока не выходит...
 
С месяцами можно поиграть
Код
instr(range("c2").value, worksheetfunction.Text(cdate("1.12.2020"),"[$-160429]mmmm"))


Например
Код
Function GetMonth(strDate As String) As Integer
For i = 1 To 12
    If InStr(strDate, WorksheetFunction.Text(i * 28, "[$-160429]mmmm")) <> 0 Then
        GetMonth = 1 + ((i + 8) Mod 12)
    Exit For
    End If
Next
End Function
Изменено: БМВ - 31.03.2020 16:04:09
По вопросам из тем форума, личку не читаю.
 
Воспользуемся в лучших традициях плодами чужого труда: :)
Код
Function Gdate(ByVal cell)
  Dim arr, d As Long, m As Long, y As Long
  arr = Split(cell)
  d = ToDbl(arr(0))
  m = GetMonth(arr(1))
  y = ToDbl(arr(2))
  Gdate = toGregorianDateObject(y, m, d)
End Function

Private Function ToDbl(ByVal s)
  ToDbl = Application.Evaluate("--" & s)
End Function

Function GetMonth(ByVal strDate As String) As Integer
For i = 1 To 12
    If InStr(strDate, WorksheetFunction.Text(i * 28, "[$-160429]mmmm")) <> 0 Then
        GetMonth = 1 + ((i + 8) Mod 12)
    Exit For
    End If
Next
End Function
Изменено: sokol92 - 31.03.2020 16:22:59
Владимир
 
Цитата
sokol92 написал:
плодами чужого труда
И снова оказана медвежья услуга  :D
По вопросам из тем форума, личку не читаю.
 
Добрый день, Михаил! Интересно, что Excel 2016 лихо умеет переводить персидские даты в григорианские. Выбираешь в формате ячейки "Дата", "Персидский", Тип календаря "Персидский", "Вставлять даты согласно выбраннному календарю", набиваешь 05.09.1398 и получаешь 26.11.2019 (что видно, если вернуть обычный формат даты).
Изменено: sokol92 - 31.03.2020 16:32:07
Владимир
 
БМВ, sokol92, спасибо огромное!!!
Да, Excel умеет переводить персидские даты типа 05.09.1398, но с исходной "۰۵ آذر ۱۳۹۸ - ۲۰:۱۴" не справляется.

Последний вопрос. Есть функция проверки наличия латиницы:
Код
Function IsLatin(Str As String) As Boolean
IsLatin = True
For i = 1 To Len(Str)
    IsLatin = IsLatin And Abs(AscW(Mid(Str, i, 1)) - 64) < 64
Next i
End Function
А как сделать проверку, что на входе персидская дата?
Не знаю, пригодится ли, но wdPersian=1065.
Изменено: Acid Burn - 31.03.2020 16:45:29
 
Функция из #10 анализирует первые три слова ячейки и интерпретирует их как число месяца, название месяца на фарси и номер года. Цифры при этом могут быть записаны привычными нам символами или "родными" арабскими (они же персидские) символами.
Если значение ячейки не соответствует этим правилам, то UDF-функция Gdate вернет значение #ЗНАЧ!
Изменено: sokol92 - 31.03.2020 18:00:16
Владимир
 
sokol92, понял, спасибо!
 
Цитата
sokol92 написал:
Выбираешь в формате ячейки "Дата", "Персидский", Тип календаря "Персидский",
а я как [$-160429] вычислял? :D

Acid Burn, по идее то что я накорябал вернет 0 если ни один из месяцев не найден в строке.
По вопросам из тем форума, личку не читаю.
 
Можно также написать отдельную функцию для проверки:

Код
Function IsPersianDate(ByVal s As String) As Boolean
  Dim d
  On Error Resume Next
  d = Gdate(s)
  On Error GoTo 0
  IsPersianDate = Not IsEmpty(d)
End Function
Изменено: sokol92 - 31.03.2020 16:58:50
Владимир
 
С функцией вообще удобно. Спасибо громадное!!!
 
Успехов!
Владимир
 
У меня почему-то  =Gdate(C2) выдаёт 22.02.2019
 
Здравствуйте, Игорь! Функция GetMonth выдает 0, поскольку Ваша версия Excel еще не знает персидского календаря (проверил у себя на Excel 2007).
Можно номер месяца (1-12) определить по списку, который есть на листе книги из #1.
Владимир
 
У меня на всех датах Gdate работает нормально (Microsoft Excel 2019 16.0.12527.20260 x32).
Но появилась проблема - ряд строк типа "KOMPAS-3D 18.1.29 x86/x64 – Russian, ۰۵ آذر ۱۳۹۸ - ۲۰:۱۴".
Как оттуда вытащить дату?

Update:
Код
Function RegexReplace(Myrange As Range, strReplace As String, strPattern As String) As String
    Dim regEx As New RegExp
    With regEx: .Global = 1: .IgnoreCase = 1: .MultiLine = 0: .Pattern = strPattern: End With
    RegexReplace = Trim(regEx.Replace(Myrange.Value, strReplace))
End Function
Формула =RegexReplace(C8;"";"[^\u0600-\u06FF\s:]") работает: тест, IsPersianDate и Gdate дату признают.
Ещё раз всем спасибо!
Изменено: Acid Burn - 31.03.2020 22:18:15
 
Ну да, у меня 2010 ещё...
Спасибо.
 
Цитата
Hugo написал:
Ну да, у меня 2010 ещё...
в 2013 уже норм.
По вопросам из тем форума, личку не читаю.
 
С этой датой ошибка: ۰۷ فروردین ۱۳۹۹ - ۰۷:۲۳ Gdate воспринимает, как 25.02.2021.
На самом деле это 07 Farvardin 1399 - 07:23, т.е. 26.03.2020.
Нужна помощь...
Изменено: Acid Burn - 01.04.2020 00:50:30
 
Acid Burn, зачем вы файл полностью заменили? Там же были полезные таблички. Вот как мне теперь понять что моя часть возвращая 12 не ошибается? да и
Цитата
Acid Burn написал:
лучше использовать таблицу [F2:G13], которую надо "спрятать" в UDF
теперь ни о чем.
По вопросам из тем форума, личку не читаю.
 
БМВ, таблицу подстановки вернул, но imho она мало, чем полезна.
Проще так: ۰۷ فروردین ۱۳۹۹ - ۰۷:۲۳ = перевод 0̱7̱ frwrdy̰n 1̱3̱9̱9̱ - 0̱7̱:2̱3̱ = 26.03.2020 (по версии GDate 25.02.2021).
Если проанализировать, то GDate получает y = 1399 (правильно), m = 12 (должно быть 1), d = 7 (правильно).
Соответственно надо править GetMonth, но вот как?
Изменено: Acid Burn - 01.04.2020 11:42:03
 
Ну как не полезна, моя GetMonth возвращает номер месяца в соответствии с вашей таблицей. и похоже она ошибается при генерации этой таблицы. А ошибается по тому что для меня филькина грамо та эти символы и не обратил внимание, что دی
встречается не только один раз. Нужно как то INSTR менять на то что даст результат более точный а не по первому найденному. По быстрому  так получилось

Код
Function GetMonth(ByVal strDate As String) As Integer
Dim i As Integer, lenStr As Integer, MaxLen As Integer, i1 As Integer
MinLen = Len(strDate)
For i = 1 To 12
    lenStr = Len(Replace(strDate, WorksheetFunction.Text(DateSerial(1900, i, 1), "[$-160429]mmmm"), ""))
    If lenStr < MinLen Then
        MinLen = lenStr
        i1 = i
    End If
Next
If i1 <> 0 Then GetMonth = 1 + ((i1 + 8) Mod 12)
End Function

Я вот подумал, что если переключить систему временно в  локацию для non UNICODE https://www.spreadsheet1.com/how-to-display-foreign-characters-in-vbe.html
то можно будет заполнить массив
Код
arrMonth=Array("فروردین", "اردیبهشت" … ) 
нужными названиями и тем самым избавится от генерации названий месяцев. Потом вернуть все обратно. Да отображаться будут ??? но должно работать.
Изменено: БМВ - 01.04.2020 12:51:01
По вопросам из тем форума, личку не читаю.
 
Добрый день! Михаил, литералы в VBA не должны содержать нерелевантные символы.

Проще всего вернуться к лобовому варианту:
Код
Function GetMonth(ByVal strDate As String) As Integer
Static arr
If Not IsArray(arr) Then
  arr = Range("d_months")
End If
For i = 1 To 12
    If StrComp(strDate, arr(i, 1), vbTextCompare) = 0 Then
        GetMonth = i
        Exit For
    End If
Next i
End Function

d_months - именованный диапазон для названий месяцев F2:F13. И работать будет для всех версий.
Изменено: sokol92 - 01.04.2020 13:25:16
Владимир
 
Цитата
sokol92 написал:
лобовому варианту:
Это скучно.  :D
По вопросам из тем форума, личку не читаю.
Страницы: 1 2 След.
Наверх