Создайте одномерный массив, разделив каждое значение ячейки на несколько целых чисел, разделенных символом, игнорируя другие символы

Question

Из нескольких столбцов диапазона я хочу в одной процедуре создать одномерный массив, разделив каждое значение ячейки (если необходимо) на несколько строк ?, преобразовать?в целые числа.Значения будут разделяться определенным символом, также он должен игнорировать другие символы

Это ... .. приведет к 1, 2, 3, 4, 7,9, 11, 13, 54, 67

Код, с которым я сейчас работаю:

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False

Dim arr As Variant
arr = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).Value   'Convert to 2-dim and use non numerical values from adjacent column, see "Excha.."

Dim varr As Variant
varr = Range("C1:E" & Range("A" & Rows.Count).End(xlUp).Row).Value  'Split if some of the cells contains multiple values delimited by character??

Dim M As Integer
M = Application.WorksheetFunction.Max(r.Offset(, 2))                'Exchange cell ref to Max(len("x2"

TextBox1.Text = ""

Dim x, y, match As Boolean, i As Integer, L As Integer

i = 1

For Each x In arr
    match = False
    For Each y In varr
        If x = y Then
            match = True
            Exit For
        End If
    Next y
    If Not match And Len(x) <> "" Then
        If i = 1 Then
            TextBox1.Text = x & ". " & Worksheets(1).Cells(x, 2).Value                                  'Exchange cell ref to "x2"
        Else
            TextBox1.Text = TextBox1.Text & String(L, " ") & x & ". " & Worksheets(1).Cells(x, 2).Value 'Exchange cell ref to "x2"
        End If
        L = M + 5 - (Len(Worksheets(1).Cells(x, 1).Value) + Len(Worksheets(1).Cells(x, 2).Value))       'Exchange cell ref to len(x)& len("x2")
    End If
        i = i + 1
    End If
Next

Application.ScreenUpdating = True
End Sub

Answer 1

Вы можете легко сделать это с помощью регулярного выражения

Option Explicit

Sub TestExtract()
    Dim Arr As Variant
    Arr = ExtractNumbers(Worksheets("Sheet1").Range("A1:F10")) 'specify which range to analyze

    Debug.Print Join(Arr, "; ") 'just to visualize the array
End Sub

Public Function ExtractNumbers(Target As Range) As Variant
    Dim regEx As Object
    Set regEx = CreateObject("vbscript.regexp")

    Dim regExMatches As Object, regExMatch As Object
    Dim Result As String

    Dim Cell As Range
    For Each Cell In Target 'loop through each cell
        If Cell.Value <> vbNullString Then
            With regEx
                .Global = True
                .MultiLine = True
                .IgnoreCase = False
                .Pattern = "[0-9]+"
            End With

            'find all integers in each cell
            Set regExMatches = regEx.Execute(Cell.Value)
            For Each regExMatch In regExMatches
                Result = Result & regExMatch & ";"
            Next regExMatch
        End If
    Next Cell

    ExtractNumbers = Split(Left$(Result, Len(Result) - 1), ";") 'convert into array
    'sort array here if needed
End Function

Обратите внимание, что я не показывал сортировку массива, потому что для этого уже есть 1 миллион учебников.