Быстрое и готовое решение для работы с градусами/VBA.Fast and ready-made solution for work with Degrees

Запись от Jack Famous размещена 18.11.2022 в 17:10

Метки degree, fast, ready-made solution, vba

Приветствую!
Моя первая запись.

Написал перечень функций и процедур для работы с градусами, минутами и секундами. Данная работа является подготовкой к созданию модуля для операций с датой-временем (там похожий принцип).
Этот код подойдёт для практикующих разработчиков на VBA, как готовое решение, заточенное на высокую скорость работы.
Постарался оттестировать, но мог что-то пропустить.

Код может:
• быстро разбирать строки вида 1°1'1'', -10°11'12'', -10°1', 1°111'', 12'1'', 12°, -15', 10'' в одномерный массив (от 0 до 3): ЗначениеВСекундах, Градусы, Минуты, Секунды.
• не разбирать строку, а просто проверить её на соответствие.
• перевести в одномерный массив, как выше, значение в секундах
• создать из массива, как выше, строку
• преобразовать градусы больше 360 и меньше 0

Скрин работы UDF на листе

Нажмите на изображение для увеличения
Название: Снимок.PNG
Просмотров: 303
Размер: 13.9 Кб
ID: 7800

Файл

Degrees.7z

Код

"Модуль «UDF»"

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
Option Explicit
'==================================================================================================
Function UDF_Degree_StringToSec(iString$) As Long
Dim aL3(0 To 3) As Long
    Degrees_Str_ToArrL3 iString, aL3
    UDF_Degree_StringToSec = aL3(0)
End Function
'==================================================================================================
Function UDF_Degree_SecToString(iSec&, Optional SkipZeros As Boolean) As String
Dim aL3(0 To 3) As Long
    Degrees_Sec_ToArrL3 iSec, aL3
    UDF_Degree_SecToString = Degrees_ArrL3_ToStr(aL3, SkipZeros)
End Function
'==================================================================================================

Модуль «Тест»

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
Option Base 1
Option Explicit
'==================================================================================================
Sub FullTest()
Dim aStr(), aArrsL3(), aStrNew() As String, aSec() As Long, aL3(0 To 3) As Long
Dim L_1(0 To 3) As Long, L_2(0 To 3) As Long, L_3(0 To 3) As Long, L_4(0 To 3) As Long, L_5(0 To 3) As Long, L_6(0 To 3) As Long, L_7(0 To 3) As Long, L_8(0 To 3) As Long
Dim tx$, t!, n&, c&
Dim sec&, a_D&, a_M&, a_S&
Const cyc& = 1000000
 
tx = "Get Arrays(Timer)": Debug.Print tx & String$(100 - Len(tx), "="),
 
t = Timer
    aStr = Array("1°1'1''", "-10°11'12''", "-10°1'", "1°111''", "12'1''", "12°", "-15'", "10''")    ' * cyc = 8 mln Operations
 
    ReDim aArrsL3(UBound(aStr))
    ReDim aStrNew(UBound(aStr))
    ReDim aSec(UBound(aStr))
    
    For n = 1 To UBound(aStr)
        Degrees_Str_ToArrL3 aStr(n), aL3
        aArrsL3(n) = aL3
        aSec(n) = aL3(0)
 
        For c = 0 To 3
            Select Case n
                Case 1: L_1(0) = aL3(0): L_1(1) = aL3(1): L_1(2) = aL3(2): L_1(3) = aL3(3)
                Case 2: L_2(0) = aL3(0): L_2(1) = aL3(1): L_2(2) = aL3(2): L_2(3) = aL3(3)
                Case 3: L_3(0) = aL3(0): L_3(1) = aL3(1): L_3(2) = aL3(2): L_3(3) = aL3(3)
                Case 4: L_4(0) = aL3(0): L_4(1) = aL3(1): L_4(2) = aL3(2): L_4(3) = aL3(3)
                Case 5: L_5(0) = aL3(0): L_5(1) = aL3(1): L_5(2) = aL3(2): L_5(3) = aL3(3)
                Case 6: L_6(0) = aL3(0): L_6(1) = aL3(1): L_6(2) = aL3(2): L_6(3) = aL3(3)
                Case 7: L_7(0) = aL3(0): L_7(1) = aL3(1): L_7(2) = aL3(2): L_7(3) = aL3(3)
                Case 8: L_8(0) = aL3(0): L_8(1) = aL3(1): L_8(2) = aL3(2): L_8(3) = aL3(3)
            End Select
        Next c
    Next n
Debug.Print Round(Timer - t, 2) ' 0.0
 
 
'================================================
tx = "String Check(Timer)": Debug.Print tx & String$(100 - Len(tx), "="),
 
t = Timer
    For c = 1 To cyc
        For n = 1 To UBound(aStr)
            If Not Degrees_Str_IsCorrect(aStr(n), , True) Then Exit Sub
        Next n
    Next c
Debug.Print Round(Timer - t, 2) ' 4.5
 
 
'================================================
tx = "String To ArrArrL3(Timer)": Debug.Print tx & String$(100 - Len(tx), "="),
 
t = Timer
    For c = 1 To cyc
        For n = 1 To UBound(aStr)
            If Not Degrees_Str_ToArrL3(aStr(n), aL3, , True) Then Exit Sub
        Next n
    Next c
Debug.Print Round(Timer - t, 2) ' 5.3
'------------------------------------------------
 
tx = "String To ArrArrL3(Check)": Debug.Print tx & String$(100 - Len(tx), "-")
 
For n = 1 To UBound(aStr)
    Degrees_Str_ToArrL3 aStr(n), aL3
 
    For c = 0 To UBound(aL3)
        If aL3(c) <> aArrsL3(n)(c) Then Debug.Print n, c, aL3(c) & "<>" & aArrsL3(n)(c)
    Next c
Next n
 
 
'================================================
tx = "Second To ArrL3(Timer)": Debug.Print tx & String$(100 - Len(tx), "="),
 
t = Timer
    For c = 1 To cyc
        For n = 1 To UBound(aSec)
            Degrees_Sec_ToArrL3 aSec(n), aL3
        Next n
    Next c
Debug.Print Round(Timer - t, 2) ' 1.0
 
'------------------------------------------------
tx = "Second To ArrL3(Check)": Debug.Print tx & String$(100 - Len(tx), "-")
 
For n = 1 To UBound(aSec)
    Degrees_Sec_ToArrL3 aSec(n), aL3
 
    For c = 0 To UBound(aL3)
        If aL3(c) <> aArrsL3(n)(c) Then Debug.Print n, c, aL3(c) & "<>" & aArrsL3(n)(c) ' 1<>0 And 51<>111 because "1°111''" = "1°0'111''" transformed to "1°1'51''"
    Next c
Next n
 
 
'================================================
tx = "ArrL3 To String(Timer)": Debug.Print tx & String$(100 - Len(tx), "="),
 
t = Timer
    For c = 1 To cyc
        aStrNew(1) = Degrees_ArrL3_ToStr(L_1, True)
        aStrNew(2) = Degrees_ArrL3_ToStr(L_2, True)
        aStrNew(3) = Degrees_ArrL3_ToStr(L_3, True)
        aStrNew(4) = Degrees_ArrL3_ToStr(L_4, True)
        aStrNew(5) = Degrees_ArrL3_ToStr(L_5, True)
        aStrNew(6) = Degrees_ArrL3_ToStr(L_6, True)
        aStrNew(7) = Degrees_ArrL3_ToStr(L_7, True)
        aStrNew(8) = Degrees_ArrL3_ToStr(L_8, True)
    Next c
Debug.Print Round(Timer - t, 2) ' 4.2
 
'------------------------------------------------
tx = "ArrL3 To String(Check)": Debug.Print tx & String$(100 - Len(tx), "-")
 
For n = 1 To UBound(aStrNew)
    Debug.Print n, aStr(n) & "<>" & aStrNew(n)
    If aStr(n) <> aStrNew(n) Then Debug.Print n, aStr(n) & "<>" & aStrNew(n) ' 1<>0 And 51<>111 because "1°111''" = "1°0'111''" transformed to "1°1'51''"
Next n
End Sub
'==================================================================================================

Модуль «Work»

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
Option Base 1
Option Explicit
'==================================================================================================
Function Degrees_Deg_FixNeg(d&) As Long
    Degrees_Deg_FixNeg = 360 + d
End Function
'==================================================================================================
Function Degrees_Deg_FixBig(d&) As Long
    Degrees_Deg_FixBig = d Mod 360
End Function
'==================================================================================================
'==================================================================================================
Function Degrees_Str_IsCorrect(v, Optional fMsgTrue As Boolean, Optional fMsgFalse As Boolean) As Boolean
Dim tx$
Static st&, RE As RegExp
    If st = 0 Then st = 1: Set RE = New RegExp: RE.Pattern = "^\d+°\d+'\d+''$|^\d+°\d+'$|^\d+°\d+''$|^\d+'\d+''$|^\d+°$|^\d+'$|^\d+''$"
    If AscW(v) = 45 Then tx = Right$(v, Len(v) - 1) Else tx = v
    Degrees_Str_IsCorrect = RE.Test(tx)
 
    If Not Degrees_Str_IsCorrect Then GoTo no
    If fMsgTrue Then MsgBox "String «" & v & "» is a Degree!", vbInformation, "Degrees_Str_IsCorrect": Exit Function Else Exit Function
no: If fMsgFalse Then MsgBox "String «" & v & "» is NOT a Degree!", vbCritical, "Degrees_Str_IsCorrect"
End Function
'==================================================================================================
' Transform String like 3°4'3'' to Array 0 To 3: LongInSec, Degreeses, Minutes, Seconds
Function Degrees_Str_ToArrL3(ByVal v$, aL3() As Long, Optional fMsgTrue As Boolean, Optional fMsgFalse As Boolean) As Boolean
Dim z&, d&, m&, s&
 
If AscW(v) = 45 Then
    z = -1: v = Right$(v, Len(v) - 1)
Else
    z = 1
End If
 
d = InStr(v, "°")
s = InStrRev(v, "''")
m = InStr(d + 1, v, "'"): If m = s Then m = 0
On Error GoTo ex
 
If d Then
    If m Then
        If s Then
            aL3(1) = Left$(v, d - 1)
            aL3(2) = Mid$(v, d + 1, m - d - 1)
            aL3(3) = Mid$(v, m + 1, s - m - 1)
        Else
            aL3(1) = Left$(v, d - 1)
            aL3(2) = Mid$(v, d + 1, m - d - 1)
            aL3(3) = 0
        End If
    Else
        If s Then
            aL3(1) = Left$(v, d - 1)
            aL3(2) = 0
            aL3(3) = Mid$(v, d + 1, s - d - 1)
        Else
            aL3(1) = Left$(v, d - 1)
            aL3(2) = 0
            aL3(3) = 0
        End If
    End If
Else
    If m Then
        If s Then
            aL3(1) = 0
            aL3(2) = Left$(v, m - 1)
            aL3(3) = Mid$(v, m + 1, s - m - 1)
        Else
            aL3(1) = 0
            aL3(2) = Left$(v, m - 1)
            aL3(3) = 0
        End If
    Else
        If s Then
            aL3(1) = 0
            aL3(2) = 0
            aL3(3) = Left$(v, s - 1)
        Else
            Stop: End
        End If
    End If
End If
 
aL3(0) = z * (3600 * aL3(1) + 60 * aL3(2) + aL3(3))
 
If fMsgTrue Then MsgBox "String «" & v & "» is a Degree!", vbInformation, "Degrees_Str_ToArrL3"
Degrees_Str_ToArrL3 = True: Exit Function
 
ex: If fMsgFalse Then MsgBox "String «" & v & "» is NOT a Degree!", vbCritical, "Degrees_Str_ToArrL3"
End Function
'==================================================================================================
Function Degrees_Sec_ToArrL3(ByVal sec&, aL3() As Long) As Boolean
 
aL3(0) = sec
sec = Abs(sec)
 
aL3(1) = sec \ 3600
aL3(2) = (sec - 3600 * aL3(1)) \ 60
aL3(3) = sec - 60 * aL3(2) - 3600 * aL3(1)
 
Degrees_Sec_ToArrL3 = True
End Function
'==================================================================================================
Function Degrees_ArrL3_ToStr(aL3() As Long, Optional fSkipZeros As Boolean) As String
 
If fSkipZeros Then
    If aL3(1) Then
        If aL3(2) Then
            If aL3(3) Then
                Degrees_ArrL3_ToStr = aL3(1) & "°" & aL3(2) & "'" & aL3(3) & "''"
            Else
                Degrees_ArrL3_ToStr = aL3(1) & "°" & aL3(2) & "'"
            End If
        Else
            If aL3(3) Then
                Degrees_ArrL3_ToStr = aL3(1) & "°" & aL3(3) & "''"
            Else
                Degrees_ArrL3_ToStr = aL3(1) & "°"
            End If
        End If
    Else
        If aL3(2) Then
            If aL3(3) Then
                Degrees_ArrL3_ToStr = aL3(2) & "'" & aL3(3) & "''"
            Else
                Degrees_ArrL3_ToStr = aL3(2) & "'"
            End If
        Else
            If aL3(3) Then
                Degrees_ArrL3_ToStr = aL3(3) & "''"
            Else
                Degrees_ArrL3_ToStr = CVErr(xlErrNA)
            End If
        End If
    End If
Else
    Degrees_ArrL3_ToStr = aL3(1) & "°" & aL3(2) & "'" & aL3(3) & "''"
End If
 
If aL3(0) < 0 Then Degrees_ArrL3_ToStr = "-" & Degrees_ArrL3_ToStr
End Function
'==================================================================================================

Метки degree, fast, ready-made solution, vba

Размещено в Без категории

Главная страница Диапазон в строку/Range to String »

Надоела реклама? Зарегистрируйтесь и она исчезнет полностью.

Всего комментариев 6

Комментарии

Если вы присмотритесь к функциям экселя, то увидите, что их названия и аргументы, за малым исключением, на русском, довольно кратки и отражают сво. суть. Понять что есть что в длинных англоязычных названиях функций и аргументов невозможно и не вызывает желания.
Далее. Очень странный функционал. Людям, работающим с градусами в формате Г° М' С'' требуется их конвертация в десятичный формат и обратно, сложение, вычитание и преобразование углов больше 360 и, в некоторых случаях, более 180.
Вследствие чего, представленный функционал крайне не функционален. Прошу прощения за тавтологию (ну или за каламбур).
Единственное с чем соглашусь, что код подойдёт для практикующих разработчиков на VBA, как готовое решение, заточенное на высокую скорость работы, в которой я даже не сомневаюсь.

Запись от Pimandr размещена 18.11.2022 в 17:55 Pimandr вне форума

Целью не было повторить русскоязычность или другие (часто спорные) параметры штатных функций. Для человека, хоть немного знакомого с основами ВБА, переписать имена процедур и аргументов не составит никакого труда. Я использую исключительно английский и только в комментариях могу допустить кириллицу.
Не знаю, что вы понимаете под десятичным форматом, т.к. функция перевода строки в секунды имеется. Любые вычисления быстрее и проще делать с целыми числами - отсюда выбор. Конвертация из секунд в любой параметр градуса не должна вызвать проблем, но помочь, если что могу).
Функционал функционален, а то, что вам он не подходит это не проблема функционала. Он точно подойдёт для большинства задач с градусами. Если есть конкретные вопросы, то создайте тему и я вам постараюсь помочь.

Запись от Jack Famous размещена 18.11.2022 в 18:32 Jack Famous вне форума

	Юлианскую дату тут не обсуждаем - всё удалю. vantfiles, предлагаю вам создать тему и в ней я бы (и другие) с вами обсудил этот вопрос. Пока вообще смысла в этом не вижу - даже, если не брать в расчёт, что это мимо моей темы.
	Запись от Jack Famous размещена 21.11.2022 в 13:33

Сообщение от Jack Famous

это мимо моей темы.

Не спорю. Просто человек никак не поймёт разницу между часами-минутами и датами.
Больше обсуждать даты не буду.

Запись от Pimandr размещена 21.11.2022 в 15:51 Pimandr вне форума

	Круто
	Запись от AlexProgramm размещена 22.11.2022 в 09:34

	AlexProgramm, спасибо)
	Запись от Jack Famous размещена 25.11.2022 в 10:13

Новые блоги и статьи Все статьи Все блоги /
Музыка, написанная Искусственным Интеллектом volvo 04.12.2025 Всем привет. Некоторое время назад меня заинтересовало, что уже умеет ИИ в плане написания музыки для песен, и, собственно, исполнения этих самых песен. Стихов у нас много, уже вышли 4 книги, еще 3. . .	От async/await к виртуальным потокам в Python IndentationError 23.11.2025 Армин Ронахер поставил под сомнение async/ await. Создатель Flask заявляет: цветные функции - провал, виртуальные потоки - решение. Не threading-динозавры, а новое поколение лёгких потоков. Откат?. . .	Поиск "дружественных имён" СОМ портов Argus19 22.11.2025 Поиск "дружественных имён" СОМ портов На странице: https:/ / norseev. ru/ 2018/ 01/ 04/ comportlist_windows/ нашёл схожую тему. Там приведён код на С++, который показывает только имена СОМ портов, типа,. . .	Сколько Государство потратило денег на меня, обеспечивая инсулином. Programma_Boinc 20.11.2025 Сколько Государство потратило денег на меня, обеспечивая инсулином. Вот решила сделать интересный приблизительный подсчет, сколько государство потратило на меня денег на покупку инсулинов. . . .	Ломающие изменения в C#.NStar Alpha Etyuhibosecyu 20.11.2025 Уже можно не только тестировать, но и пользоваться C#. NStar - писать оконные приложения, содержащие надписи, кнопки, текстовые поля и даже изображения, например, моя игра "Три в ряд" написана на этом. . .
Мысли в слух kumehtar 18.11.2025 Кстати, совсем недавно имел разговор на тему медитаций с людьми. И обнаружил, что они вообще не понимают что такое медитация и зачем она нужна. Самые базовые вещи. Для них это - когда просто люди. . .	Создание Single Page Application на фреймах krapotkin 16.11.2025 Статья исключительно для начинающих. Подходы оригинальностью не блещут. В век Веб все очень привыкли к дизайну Single-Page-Application . Быстренько разберем подход "на фреймах". Мы делаем одну. . .	Фото: Daniel Greenwood kumehtar 13.11.2025	Расскажи мне о Мире, бродяга kumehtar 12.11.2025 — Расскажи мне о Мире, бродяга, Ты же видел моря и метели. Как сменялись короны и стяги, Как эпохи стрелою летели. - Этот мир — это крылья и горы, Снег и пламя, любовь и тревоги, И бескрайние. . .	PowerShell Snippets iNNOKENTIY21 11.11.2025 Модуль PowerShell 5. 1+ : Snippets. psm1 У меня модуль расположен в пользовательской папке модулей, по умолчанию: \Documents\WindowsPowerShell\Modules\Snippets\ А в самом низу файла-профиля. . .

Сообщение форума

Отменить изменения