Функция ParseColumnsStringEx предназначена для преобразования введенного пользователем списка столбцов в одномерный массив числовых значений.

Назначение функции: исключить ошибки пользовательского ввода, преобразовать буквенные названия столбцов в числовые значения.

Пример использования:

Private Sub ПримерИспользования_ParseColumnsStringEx()

    Dim txt$, txt1$, txt2$

    ' исходная строка с номерами столбцов (c ошибками ввода)

    txt$ = "4-4 , -a- C;8,Я-7,-11-9-F, Е --К; 4,21-,6-F"

    ' получаем массив столбцов

    arr = ParseColumnsStringEx(txt)

    ' выводим список столбцов:  4,1,2,3,8,7,11,10,9,8,7,6,5,6,7,8,9,10,11,4,21,6,

    For i = LBound(arr) To UBound(arr): Debug.Print arr(i) & ",";: Next i: Debug.Print

    ' ======================================

    ' или, например, такая строка

    txt$ = "4-5,8 -k, 6-5;a,e,3,4, 46-BA"

    ' получаем массив столбцов (c «промежуточными» значениями)

    arr2 = ParseColumnsStringEx(txt, txt1, txt2)

    Debug.Print txt1    ' выводит  4-5;8-K;6-5;A;E;3;4;46-BA

    Debug.Print txt2    ' выводит  4-5,8-11,6-5,1,5,3,4,46-53

    columnsList$ = Join(arr2, ",")

    Debug.Print columnsList$    ' выводит 4,5,8,9,10,11,6,5,1,5,3,4,46,47,48,49,50,51,52,53

End Sub

Код функции ParseColumnsStringEx:

Function ParseColumnsStringEx(ByVal txt$, Optional ByRef norm1$, Optional ByRef norm2$) As Variant

    ' Принимает в качестве параметра строку типа "A-C;8,,11-9, Е-К; 4,21,"

    ' Возвращает одномерный (горизонтальный) массив в формате Array(1,2,3,8,11,10,9,5,6,7,8,9,10,11,4,21)

    ' (пустые значения удаляются; диапазоны типа 9-15 и 17-13 раскрываются,

    '  буквенные диапазоны заменяются на числовые, русские буквы заменяются латинскими)

    On Error Resume Next

    ' устраняем возможные ошибки пользовательского ввода

    Const enARR$ = "ABCEHKMOPTX", ruARR$ = "АВСЕНКМОРТХ"

    Const cc& = 256      ' ограничение на максимальный номер столбца

    For i = 1 To Len(enARR$): txt = Replace(txt, Mid(ruARR$, i, 1), Mid(enARR$, i, 1)): Next i

    txt = Replace(txt, " ", ""): txt = Replace(txt, ";", ",")

    txt = Replace(txt, ":", "-"): txt = Replace(txt, ".", ","): txt = UCase(txt)

    For i = 1 To Len(txt)

        If Not Mid(txt, i, 1) Like "[A-Z0-9,-]" Then Mid(txt, i, 1) = ","

    Next i

    While InStr(1, txt, ",,"): txt = Replace(txt, ",,", ","): Wend

    While InStr(1, txt, "--"): txt = Replace(txt, "--", "-"): Wend

    txt = Replace(txt, ",-", ","): txt = Replace(txt, "-,", ",")

    If Left(txt, 1) = "-" Or Left(txt, 1) = "," Then txt = Mid(txt, 2)

    If Right(txt, 1) = "-" Or Right(txt, 1) = "," Then txt = Left(txt, Len(txt) - 1)

    norm1$ = Replace(txt$, ",", ";")  ' возвращаем «нормализованную» строку для подстановки в поле

    arr = Split(txt$, ","): Dim n As Long: ReDim tmpArr(0 To 0)

    For i = LBound(arr) To UBound(arr)

        spl = Split(arr(i), "-")

        For j = LBound(spl) To UBound(spl)

            cn& = 0: cn& = ColumnNameToColumnNumber(spl(j)): If cn& Then spl(j) = cn&

            If Not spl(j) Like String(Len(spl(j)), "#") Then spl(j) = ""

        Next j

        If Val(spl(0)) > cc& Then spl(0) = "": spl(UBound(spl)) = ""

        If Val(spl(UBound(spl))) > cc& Then spl(UBound(spl)) = cc&

        If UBound(spl) > 1 Then arr(i) = spl(0) & "-" & spl(UBound(spl)) Else arr(i) = Join(spl, "-")

        If UBound(spl) = 1 Then If spl(0) = spl(1) Then arr(i) = spl(0)

        If UBound(spl) = 1 Then If spl(0) = "" Then arr(i) = spl(1)

    Next i

    norm2$ = Join(arr, ","): norm2$ = Replace(norm2$, ",-", ","): norm2$ = Replace(norm2$, "-,", ",")

    While InStr(1, norm2$, ",,"): norm2$ = Replace(norm2$, ",,", ","): Wend

    If Left(norm2$, 1) = "," Then norm2$ = Mid(norm2$, 2)

    If Right(norm2$, 1) = "," Then norm2$ = Left(norm2$, Len(norm2$) - 1)

    For i = LBound(arr) To UBound(arr)

        Select Case True

            Case arr(i) = "", Val(arr(i)) < 0

            Case IsNumeric(arr(i))

                tmpArr(UBound(tmpArr)) = arr(i): ReDim Preserve tmpArr(0 To UBound(tmpArr) + 1)

            Case arr(i) Like "*#-#*"

                spl = Split(arr(i), "-")

                If UBound(spl) = 1 Then

                    If IsNumeric(spl(0)) And IsNumeric(spl(1)) Then

                        If spl(0) <= cc& Then

                            If spl(1) > cc& Then spl(1) = cc&

                            For j = Val(spl(0)) To Val(spl(1)) Step IIf(Val(spl(0)) > Val(spl(1)), -1, 1)

                                tmpArr(UBound(tmpArr)) = j: ReDim Preserve tmpArr(0 To UBound(tmpArr) + 1)

                            Next j

                        End If

                    End If

                End If

        End Select

    Next i

    If UBound(tmpArr) Then

        ReDim Preserve tmpArr(0 To UBound(tmpArr) - 1)

        ParseColumnsStringEx = tmpArr

    End If

End Function

Function ColumnNameToColumnNumber(ByVal txt$) As Long

    On Error Resume Next    ' преобразует имя столбца в номер.   в случае ошибки возвращает 0

    ColumnNameToColumnNumber = Split(Application.ConvertFormula(txt$ & "1", xlA1, xlR1C1, True), "C")(1)

End Function

• 4710 просмотров