Private Sub Test_Shell()
Dim n&
    n = Shell("C:\WINDOWS\NOTEPAD.EXE", vbHide)         ' Run Notepad and Hide it immediately
    n = Shell("C:\WINDOWS\NOTEPAD.EXE", vbNormalFocus)  ' Run Notepad and set it Active
    Debug.Print n
End Sub

Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Public Const PROCESS_QUERY_INFORMATION& = &H400, SYNCHRONIZE = &H100000, STILL_ACTIVE& = &H103
Public Const vc_Cyc_2bil& = 2000000000
'==================================================================================================
Private Declare PtrSafe Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As Long, lpExitCode As Long) As Long
'==================================================================================================
Function PRDX_API_ShellAndWait(sCommand$, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim p&, c&, e&, n&
 
p = Shell(sCommand, 0):                        If (p = 0) Then If MsgFalse Then MsgBox "Shell with command:" & vbLf & sCommand & vbLf & "is OUT!", vbCritical, "PRDX_API_ShellAndWait": Exit Function Else Exit Function
p = OpenProcess(PROCESS_QUERY_INFORMATION, 0, p):   If (p = 0) Then If MsgFalse Then MsgBox "OpenProcess of Shell with command:" & vbLf & sCommand & vbLf & "is OUT!", vbCritical, "PRDX_API_ShellAndWait": Exit Function Else Exit Function
 
For n = 1 To vc_Cyc_2bil
    e = GetExitCodeProcess(p, c): DoEvents:         If (e = 0) Then If MsgFalse Then MsgBox "GetExitCodeProcess of Shell with command:" & vbLf & sCommand & vbLf & "is OUT!", vbCritical, "PRDX_API_ShellAndWait": Exit Function Else Exit Function
    If (c <> STILL_ACTIVE) Then Exit For
Next n
 
If (n > vc_Cyc_2bil) Then n = 0:                    If MsgFalse Then MsgBox "Cycle to GetExitCodeProcess of Shell with command:" & vbLf & sCommand & vbLf & "was LOOPED!", vbCritical, "PRDX_API_ShellAndWait": Exit Function Else Exit Function
 
PRDX_API_ShellAndWait = True:                       If MsgTrue Then MsgBox "Shell with command:" & vbLf & sCommand & vbLf & "was succsessfully finished in " & Format$(n, "#,#") & " Cycles!", vbInformation, "PRDX_API_ShellAndWait"
End Function

Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Function PRDX_Arr2D_To1D_AlignmentStrings(a2D, a1D_Res$(), Optional ByVal sepJoin$ = " ") As Long
Dim aLen&(), tx$, txSp$, r&, c&, l&, lSep&
 
ReDim a1D_Res(UBound(a2D, 1))
ReDim aLen(UBound(a2D, 2))
 
For c = 1 To UBound(a2D, 2)
    For r = 1 To UBound(a2D, 1)
        l = Len(a2D(r, c))
        If l > aLen(c) Then aLen(c) = l
    Next r
Next c
 
l = 0
For c = 1 To UBound(aLen)
    l = l + aLen(c)
Next c
 
lSep = Len(sepJoin)
l = l + lSep * (UBound(aLen) - 1)
PRDX_Arr2D_To1D_AlignmentStrings = l
txSp = Space$(l): l = 0
 
For r = 1 To UBound(a2D, 1)
    tx = txSp
 
    For c = 1 To UBound(a2D, 2) - 1
        Mid$(tx, l + 1, aLen(c)) = a2D(r, c):   l = l + aLen(c)
        Mid$(tx, l + 1, lSep) = sepJoin:        l = l + lSep
    Next c
 
    Mid$(tx, l + 1, aLen(c)) = a2D(r, c)
    a1D_Res(r) = tx: l = 0
Next r
End Function
'--------------------------------------------------------------------------------------------------
Private Sub TestSpeed_PRDX_Arr2D_To1D_AlignmentStrings()
Dim bef$(), aft$()
Dim t!, n&, l&
Const nCyc& = 1000000
 
ReDim bef(3, 3)
bef(1, 1) = "My dream": bef(1, 2) = "is":   bef(1, 3) = "to fly"
bef(2, 1) = "Over":     bef(2, 2) = "the":  bef(2, 3) = "rainbow"
bef(3, 1) = "So":       bef(3, 2) = "":     bef(3, 3) = "high"
 
t = Timer
    For n = 1 To nCyc
        l = PRDX_Arr2D_To1D_AlignmentStrings(bef, aft, " — ")  ' 3.23
    Next n
Debug.Print Format$(Timer - t, "0.00"), l
Debug.Print Join(aft, vbLf)
End Sub

Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Function TextMult(ByVal v$, Mult&, Optional ByVal Sep$ = " ") As String
Dim tx$, n&
 
For n = 1 To Mult
    tx = tx & Sep & v
Next n
 
TextMult = Mid$(tx, Len(Sep) + 1)
End Function
'==================================================================================================
Private Sub Test()
Dim aFnd, aRpl
Dim tx$, res$, t!, n&, nR&
Const nCyc& = 100000, nMult& = 10   ' nMult=1 Для проверки исходной строки
 
tx = "Вася вас не Вас,Петя:пет;не,Пет,Alexey-alex*not«Alex»"
aFnd = Array("вас", "пет", "alex")
aRpl = Array("Василий Семёнович", "Пётр Петрович", "Jack")
 
' Раскомментировать, если нужно проверить
'res = tx: Debug.Print PRDX_Text_Replace_WholeWord(res, "вас", "Василий Семёнович"), res    ' 1 | Вася Василий Семёнович не Вас,Петя:пет;не,Пет,Alexey-alex*not«Alex»
'res = tx: Debug.Print PRDX_Text_Replace_WholeWord(res, "пет", "Пётр Петрович", True), res  ' 2 | Вася вас не Вас,Петя:Пётр Петрович;не,Пётр Петрович,Alexey-alex*not«Alex»
'res = tx: Debug.Print PRDX_Text_Replace_WholeWord_Array(res, aFnd, aRpl), res              ' 3 | Вася Василий Семёнович не Вас,Петя:Пётр Петрович;не,Пет,Alexey-Jack*not«Alex»
'res = tx: Debug.Print PRDX_Text_Replace_WholeWord_Array(res, aFnd, aRpl, True), res        ' 6 | Вася Василий Семёнович не Василий Семёнович,Петя:Пётр Петрович;не,Пётр Петрович,Alexey-Jack*not«Jack»
 
' Число замен рассчитано с помощью RE.Execute().Count. Считает некорректно. Убрал. Если оставить, то увеличивает время выполнения примерно в 2 раза.
'res = tx: Debug.Print IG_ReplaceWholeWord(res, "вас", "Василий Семёнович"), res            ' 1 | Вася Василий Семёнович не Вас,Петя:пет;не,Пет,Alexey-alex*not«Alex»
'res = tx: Debug.Print IG_ReplaceWholeWord(res, "пет", "Пётр Петрович", True), res          ' 2 | Вася вас не Вас,Петя:Пётр Петрович;не,Пётр Петрович,Alexey-alex*not«Alex»
'res = tx: Debug.Print IG_ReplaceWholeWord_Array(res, aFnd, aRpl), res                      ' 1 | Вася Василий Семёнович не Вас,Петя:Пётр Петрович;не,Пет,Alexey-Jack*not«Alex»
'res = tx: Debug.Print IG_ReplaceWholeWord_Array(res, aFnd, aRpl, True), res                ' 2 | Вася Василий Семёнович не Василий Семёнович,Петя:Пётр Петрович;не,Пётр Петрович,Alexey-Jack*not«Jack»
 
 
tx = TextMult(tx, nMult)
 
t = Timer                                                                                   ' Исх.  | x10
    For n = 1 To nCyc / nMult
        res = tx: nR = PRDX_Text_Replace_WholeWord_Array(res, aFnd, aRpl)                  ' 2.58 | 1.78
'        res = tx: nR = PRDX_Text_Replace_WholeWord_Array(res, aFnd, aRpl, True)            ' 2.89 | 1.97
 
'        res = tx: nR = IG_ReplaceWholeWord_Array(res, aFnd, aRpl)                          ' 2.64 | 1,48
'        res = tx: nR = IG_ReplaceWholeWord_Array(res, aFnd, aRpl, True)                    ' 2,98 | 1.66
    Next n
Debug.Print Format$(Timer - t, "0.00"), nR
 
End Sub
'==================================================================================================
'==================================================================================================
Function PRDX_Text_Replace_WholeWord(tmpString, ByVal iFnd$, ByVal iRpl$, Optional CaseIgnore As Boolean) As Long
Dim aWrd$(), aSep$()
Dim n&, nRpl&
 
If Not LCase$(tmpString) Like "*[a-zёа-я]*" Then Exit Function
If Not PRDX_SplitString_ByNonCyrLat(tmpString, aWrd, aSep) Then Stop: End
 
If CaseIgnore Then
    iFnd = LCase$(iFnd)
    For n = 1 To UBound(aWrd)
        If iFnd = LCase$(aWrd(n)) Then nRpl = nRpl + 1: aWrd(n) = iRpl
    Next n
Else
    For n = 1 To UBound(aWrd)
        If iFnd = aWrd(n) Then nRpl = nRpl + 1: aWrd(n) = iRpl
    Next n
End If
 
If nRpl Then PRDX_Text_Replace_WholeWord = nRpl Else Exit Function
tmpString = PRDX_SplitString_ByNonCyrLat_Join(aWrd, aSep)
End Function
'==================================================================================================
Function PRDX_Text_Replace_WholeWord_Array(tmpString, aFind, aRpl, Optional CaseIgnore As Boolean) As Long
Dim aWrd$(), aSep$()
Dim tx$, f&, n&, nRpl&
Static st&, dic As Dictionary
 
If Not LCase$(tmpString) Like "*[a-zёа-я]*" Then Exit Function
If st = 0 Then st = 1: Set dic = New Dictionary
If Not PRDX_SplitString_ByNonCyrLat(tmpString, aWrd, aSep) Then Stop: End
 
If CaseIgnore Then
    For n = LBound(aFind) To UBound(aFind)
        tx = LCase$(aFind(n))
        If Not dic.Exists(tx) Then dic.Add tx, aRpl(n)
    Next n
 
    For n = 1 To UBound(aWrd)
        tx = LCase$(aWrd(n))
        If dic.Exists(tx) Then nRpl = nRpl + 1: aWrd(n) = dic(tx)
    Next n
Else
    For n = LBound(aFind) To UBound(aFind)
        tx = aFind(n)
        If Not dic.Exists(tx) Then dic.Add tx, aRpl(n)
    Next n
 
    For n = 1 To UBound(aWrd)
        If dic.Exists(aWrd(n)) Then nRpl = nRpl + 1: aWrd(n) = dic(aWrd(n))
    Next n
End If
 
dic.RemoveAll
If nRpl Then PRDX_Text_Replace_WholeWord_Array = nRpl Else Exit Function
tmpString = PRDX_SplitString_ByNonCyrLat_Join(aWrd, aSep)
End Function
'==================================================================================================
'==================================================================================================
Function IG_ReplaceWholeWord(tmpString, ByVal iFnd$, ByVal iRpl$, Optional CaseIgnore As Boolean) As Boolean
Dim x, tx$
Static st&, RE As RegExp, REci As RegExp
 
If st = 0 Then
    st = 1
    Set RE = New RegExp: RE.Global = True
    Set REci = New RegExp: REci.Global = True: REci.IgnoreCase = True
End If
 
If CaseIgnore Then
    tx = "(^|[^a-zа-яё])" & iFnd & "(?=[^a-zа-яё]|$)"
    If REci.Pattern <> tx Then REci.Pattern = tx
 
    If REci.Test(tmpString) Then IG_ReplaceWholeWord = True Else Exit Function
    tmpString = REci.Replace(tmpString, "$1" & iRpl)
Else
    tx = "(^|[^A-Za-zА-яЁё])" & iFnd & "(?=[^A-Za-zА-яЁё]|$)"
    If RE.Pattern <> tx Then RE.Pattern = tx
 
    If RE.Test(tmpString) Then IG_ReplaceWholeWord = True Else Exit Function
    tmpString = RE.Replace(tmpString, "$1" & iRpl)
End If
 
End Function
'==================================================================================================
Function IG_ReplaceWholeWord_Array(tmpString, aFind, aRpl, Optional CaseIgnore As Boolean) As Boolean
Dim x, n&
Static st&, RE As RegExp, REci As RegExp
 
If st = 0 Then
    st = 1
    Set RE = New RegExp: RE.Global = True
    Set REci = New RegExp: REci.Global = True: REci.IgnoreCase = True
End If
 
If CaseIgnore Then
    For n = LBound(aFind) To UBound(aFind)
        REci.Pattern = "(^|[^a-zа-яё])" & aFind(n) & "(?=[^a-zа-яё]|$)"
    
        If REci.Test(tmpString) Then IG_ReplaceWholeWord_Array = True Else Exit Function
        tmpString = REci.Replace(tmpString, "$1" & aRpl(n))
    Next n
Else
    For n = LBound(aFind) To UBound(aFind)
        RE.Pattern = "(^|[^A-Za-zА-яЁё])" & aFind(n) & "(?=[^A-Za-zА-яЁё]|$)"
    
        If RE.Test(tmpString) Then IG_ReplaceWholeWord_Array = True Else Exit Function
        tmpString = RE.Replace(tmpString, "$1" & aRpl(n))
    Next n
End If
End Function

Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
' Num: 48-57
' Lat: 65-90; 97-122
' Cyr: 1025; 1040-1103; 1105
'==================================================================================================
'==================================================================================================
'==================================================================================================
Function PRDX_AscW_CyrAndLat_GetArr() As Long()
Dim a&(1105), s&
 
For s = 65 To 1105
    Select Case s
        Case 91:    s = 97
        Case 123:   s = 1025
        Case 1026:  s = 1040
        Case 1104:  s = 1105
    End Select
    a(s) = 1
Next s
 
PRDX_AscW_CyrAndLat_GetArr = a
End Function
'==================================================================================================
Function PRDX_AscW_CyrAndLat_Is(iAscW&) As Boolean
Static st&, a&()
    If iAscW > 1105 Then Exit Function
    If st = 0 Then st = 1: a = PRDX_AscW_CyrAndLat_GetArr()
    If a(iAscW) Then PRDX_AscW_CyrAndLat_Is = True
End Function

Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Private Sub Test_PRDX_SplitString_ByNonCyrLat()
Dim x, w$(), s$(), n&
 
x = ",./asd.gh./*красота/*b./7jg,,./"
If Not PRDX_SplitString_ByNonCyrLat(x, w, s) Then Exit Sub
 
For n = 1 To UBound(s)
    Debug.Print "«" & s(n) & "»"
    If n < UBound(s) Then Debug.Print "«" & w(n) & "»"
Next n
 
Debug.Print x = PRDX_SplitString_ByNonCyrLat_Join(w, s)
End Sub
'==================================================================================================
'==================================================================================================
' Fill aWrd(N) and aSep(N+1)
Function PRDX_SplitString_ByNonCyrLat(ByVal iStr$, aWrd$(), aSep$()) As Boolean
Dim aBt() As Byte
Dim i&, n&, nW&, nS&, bW&, bS&
 
aBt = iStr
ReDim aWrd(Len(iStr))
ReDim aSep(UBound(aWrd))
 
For i = 0 To UBound(aBt) Step 2
    n = n + 1
 
    If PRDX_AscW_CyrAndLat_Is(aBt(i) + 256 * aBt(i + 1)) Then   ' Ltr
        If bW Then GoTo nx Else bW = n
 
        If bS = 0 Then
            If nS = 0 Then nS = nS + 1: aSep(nS) = ""
            GoTo nx
        End If
 
        nS = nS + 1: aSep(nS) = Mid$(iStr, bS, n - bS): bS = 0
    Else                                                        ' NonLtr
        If bS Then GoTo nx Else bS = n
        If bW = 0 Then GoTo nx
        nW = nW + 1: aWrd(nW) = Mid$(iStr, bW, n - bW): bW = 0
    End If
nx:
Next i
 
If bW Then
    nW = nW + 1: aWrd(nW) = Mid$(iStr, bW)
Else
    nS = nS + 1: aSep(nS) = Mid$(iStr, bS)
End If
 
If nW = 0 Then Stop: End
If nS < nW Then Stop: End
If nS > nW + 1 Then Stop: End
If nS = nW Then nS = nS + 1: aSep(nS) = ""
 
ReDim Preserve aWrd(nW)
ReDim Preserve aSep(nS)
PRDX_SplitString_ByNonCyrLat = True
End Function
'==================================================================================================
Function PRDX_SplitString_ByNonCyrLat_Join(aWrd$(), aSep$()) As String
Dim tx$, n&
 
For n = 1 To UBound(aWrd)
    tx = tx & aSep(n) & aWrd(n)
Next n
 
PRDX_SplitString_ByNonCyrLat_Join = tx & aSep(UBound(aSep))
End Function
'==================================================================================================

Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Function PRDX_SplitString_ByNonCyrLat_Join(aWrd$(), aSep$(), iLen&) As String
Dim tx$, n&, p&, l&
 
tx = String$(iLen, " "): p = 1
 
l = Len(aSep(1))
If l Then Mid$(tx, p, l) = aSep(1):         p = p + l
l = Len(aWrd(1)): Mid$(tx, p, l) = aWrd(1): p = p + l
 
For n = 2 To UBound(aWrd)
    l = Len(aSep(n)): Mid$(tx, p, l) = aSep(n): p = p + l
    l = Len(aWrd(n)): Mid$(tx, p, l) = aWrd(n): p = p + l
Next n
 
l = Len(aSep(n))
If l Then Mid$(tx, p, l) = aSep(n)
 
PRDX_SplitString_ByNonCyrLat_Join = tx
End Function
'--------------------------------------------------------------------------------------------------
Function PRDX_SplitString_ByNonCyrLat_Join2(aWrd$(), aSep$()) As String
Dim tx$, n&
 
If Len(aSep(1)) Then
    tx = aSep(1) & aWrd(1)
Else
    tx = aWrd(1)
End If
 
For n = 2 To UBound(aWrd)
    tx = tx & aSep(n) & aWrd(n)
Next n
 
If Len(aSep(n)) Then
    PRDX_SplitString_ByNonCyrLat_Join2 = tx & aSep(n)
Else
    PRDX_SplitString_ByNonCyrLat_Join2 = tx
End If
 
End Function
'--------------------------------------------------------------------------------------------------
Function PRDX_SplitString_ByNonCyrLat_Join3(aWrd$(), aSep$()) As String
Dim a$(), tx$, n&, j&
 
n = UBound(aWrd) + UBound(aSep)
 
If Len(aSep(1)) Then
    If Len(aSep(UBound(aSep))) Then
        ReDim a(n)
 
        For n = 1 To UBound(aWrd)
            j = j + 1: a(j) = aSep(n)
            j = j + 1: a(j) = aWrd(n)
        Next n
    
        j = j + 1: a(j) = aSep(n)
    Else
        ReDim a(n - 1)
 
        For n = 1 To UBound(aWrd)
            j = j + 1: a(j) = aSep(n)
            j = j + 1: a(j) = aWrd(n)
        Next n
    End If
Else
    If Len(aSep(UBound(aSep))) Then
        ReDim a(n - 1)
        j = j + 1: a(j) = aWrd(1)
 
        For n = 2 To UBound(aWrd)
            j = j + 1: a(j) = aSep(n)
            j = j + 1: a(j) = aWrd(n)
        Next n
 
        j = j + 1: a(j) = aSep(n)
    Else
        ReDim a(n - 2)
        j = j + 1: a(j) = aWrd(1)
 
        For n = 2 To UBound(aWrd)
            j = j + 1: a(j) = aSep(n)
            j = j + 1: a(j) = aWrd(n)
        Next n
    End If
End If
 
PRDX_SplitString_ByNonCyrLat_Join3 = Join(a, "")
End Function
'==================================================================================================
Private Sub Test_PRDX_SplitString_ByNonCyrLat_Join()
Dim tx$, w$(), s$()
Dim res$, t!, n&, l&
 
tx = "asd.gh7jg.sdfsddf.234sfd.sdfs sdfsdfjjkl"
tx = "." & tx & "." ' UnComment for .*.
l = Len(tx)
If Not PRDX_SplitString_ByNonCyrLat(tx, w, s) Then Exit Sub
 
t = Timer
    For n = 1 To 1000000                                    '  *    / .*.
'        res = PRDX_SplitString_ByNonCyrLat_Join(w, s, l)   ' 0.72  / 0.77
'        res = PRDX_SplitString_ByNonCyrLat_Join2(w, s)     ' 0.96  / 1.02
'        res = PRDX_SplitString_ByNonCyrLat_Join3(w, s)     ' 1.71  / 1.95
    Next n
Debug.Print Format$(Timer - t, "0.00"), res = tx, "«" & res & "»"
End Sub

Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
' РАБОТАЕТ 10 минут !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Sub Test()
Dim aSym()
Dim tx$, ch$, t!, n&, r&
Const nn& = 65535
 
t = Timer
tx = "abcd"
ReDim aSym(nn, 2) ' AscW, Char
 
On Error Resume Next
    For n = 1 To nn
        If n = 32 Then n = 33
        ch = ChrW(n): If Err Then Stop
        ActiveWorkbook.Names.Add ch & tx, [a1]
 
        If Err.Number = 0 Then
            r = r + 1
            aSym(r, 1) = n
            aSym(r, 2) = ch
            ActiveWorkbook.Names(ch & tx).Delete
            If Err Then Stop: End
        Else
            Err.Clear
        End If
    Next n
On Error GoTo 0
 
If r = 0 Then Stop: End
[a2].Resize(nn, 2).ClearContents
[a2].Resize(r, 2).Value2 = aSym
 
MsgBox "Find&Load Symbols: " & Format$(r, "#,##0"), vbInformation, Format$(Timer - t, "0.00")
End Sub
'==================================================================================================
Sub ShowSelected()
Dim cl As Range
    For Each cl In Selection
        Debug.Print cl.Row, cl
    Next cl
End Sub
'==================================================================================================

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
'==================================================================================================

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
'==================================================================================================

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
'==================================================================================================