Доброй ночи! Думаю кроме того что там всё довольно запутано, проблема в том что в коде не получится легко прописать эти персидские символы. Наверное есть смысл поискать что-то другое уже готовое, должно ведь быть!
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
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
Переводчики тут не помогут - лучше использовать таблицу [F2:G13], которую надо "спрятать" в UDF. В [С3] есть готовая формула, написанная на скорую руку, но всё же рабочая. Есть Sub Test() и Sub tt(). Вроде всего достаточно, но синтезировать готовую UDF пока не выходит...
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
Воспользуемся в лучших традициях плодами чужого труда:
Код
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
Добрый день, Михаил! Интересно, что Excel 2016 лихо умеет переводить персидские даты в григорианские. Выбираешь в формате ячейки "Дата", "Персидский", Тип календаря "Персидский", "Вставлять даты согласно выбраннному календарю", набиваешь 05.09.1398 и получаешь 26.11.2019 (что видно, если вернуть обычный формат даты).
БМВ, 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.
Функция из #10 анализирует первые три слова ячейки и интерпретирует их как число месяца, название месяца на фарси и номер года. Цифры при этом могут быть записаны привычными нам символами или "родными" арабскими (они же персидские) символами. Если значение ячейки не соответствует этим правилам, то UDF-функция Gdate вернет значение #ЗНАЧ!
Можно также написать отдельную функцию для проверки:
Код
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
Здравствуйте, Игорь! Функция 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 дату признают. Ещё раз всем спасибо!
С этой датой ошибка: ۰۷ فروردین ۱۳۹۹ - ۰۷:۲۳ Gdate воспринимает, как 25.02.2021. На самом деле это 07 Farvardin 1399 - 07:23, т.е. 26.03.2020. Нужна помощь...
БМВ, таблицу подстановки вернул, но 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, но вот как?
Ну как не полезна, моя 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
Добрый день! Михаил, литералы в 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. И работать будет для всех версий.