Поиск номеров в строке VBA

Question

Я пытаюсь найти символы числового типа в последовательных позициях (не менее 3) в строке.Например, если у меня есть эта строка:

"Lorem ipsum dolor sit amet, consittetur adipiscing elit. Nulla purus dui, lobortis non 54 leo non, feugiat venenatis urna. Morbilobortis ligula tincidunt 1844763 , accumsan massa vel, placerat libero. В нисле в leo lacinia 243 ullamcorper eget id tortor. Cras vehicleula malesuada luctus. Donec egestas non arcu in bland. Donec egestas non arcu in bland.lacinia ipsum и др. mi. Nulla 46626 laoreet viverra purus fringilla pellentesque. Mauris sit amet pulvinar Velit, в dignissim lacus. Меценаты не соллисвитные, например, Fusce luctus enim eff 43 * 101i finit ic. Nam ac 1 fermentum lacus. "

Я хочу, чтобы мой скрипт VBA возвращал это:

1844763
243
46626

Это скрипт, с которым я сейчас работаю:

                start = 1
                Do
                    If IsNumeric(Mid(Sheets("Sheet1").Cells(x, 1), start, 1)) Then
                        If start = Len(Sheets("Sheet1").Cells(x, 1)) Then
                            Exit Do
                        End If
                        If IsNumeric(Mid(Sheets("Sheet1").Cells(x, 1), start + 1, 1)) Then
                            If start + 1 = Len(Sheets("Sheet1").Cells(x, 1)) Then
                                Exit Do
                            End If
                            If IsNumeric(Mid(Sheets("Sheet1").Cells(x, 1), start + 2, 1)) Then
                                Sheets("Sheet1").Cells(x, 2).Interior.Color = RGB(255, 0, 0)
                                Sheets("Sheet1").Cells(x, 2) = Sheets("Sheet1").Cells(x, 2) & Mid(Sheets("Sheet1").Cells(x, 1), start, 3)
                                start = start + 3
                                While IsNumeric(Mid(Sheets("Sheet1").Cells(x, 1), start, 1))
                                    Sheets("Sheet1").Cells(x, 2) = Sheets("Sheet1").Cells(x, 2) & Mid(Sheets("Sheet1").Cells(x, 1), start, 1)
                                    start = start + 1
                                Wend
                                Sheets("Sheet1").Cells(x, 2) = Sheets("Sheet1").Cells(x, 2) & vbCrLf
                            End If
                        End If
                    End If
                   If Not IsNumeric(Mid(Sheets("Sheet1").Cells(x, 1), start, 1)) Then
                        start = start + 1
                    End If
                Loop While inicio < Len(Sheets("Comments").Cells(x, 1))

Скрипт отлично работает с небольшими строками (10-20 символов).При работе со строками, подобными приведенным выше, дела идут не так, как надо (мой компьютер значительно замедляется и Excel навсегда перестает отвечать на запросы).У вас есть идеи, как оптимизировать этот код?

Спасибо!

Answer 1

Вот решение с регулярными выражениями.Вывод помещается в отдельные ячейки, но может быть возвращен в виде строки и т. Д. Возможно, превратить его в UDF?

Sub Regex2()

Dim oMatches As Object, i As Long, vOut

With CreateObject("VBScript.RegExp")
    .Global = True
    .Pattern = "\d{3,}"
    If .Test(Range("A1")) Then
        Set oMatches = .Execute(Range("A1"))
        ReDim vOut(0 To oMatches.Count - 1)
        For i = 0 To oMatches.Count - 1
            vOut(i) = oMatches(i).Value
        Next i
        Range("B1").Resize(i) = WorksheetFunction.Transpose(vOut)
    End If
End With

End Sub

Answer 2

хотя и не является пуленепробиваемым, вы можете использовать эту функцию:

Function GetNumbersWithAtLeastThreeDigits(ByVal s As String) As String
    Dim charsToRemove As String
    charsToRemove = "abcdefghijklmnopqrstuvwxyz.," 

    s = LCase(s)
    Dim i As Long
    For i = 1 To Len(charsToRemove)
        s = Replace(s, Mid(charsToRemove, i, 1), "")
    Next

    Dim res As String
    Dim v As Variant
    For Each v In Split(WorksheetFunction.Trim(s), " ")
        If CLng(Val(v)) > 99 Then res = res & Val(v) & vbNewLine
    Next

    GetNumbersWithAtLeastThreeDigits = res
End Function

, которая будет возвращать строку со всеми найденными числами, разделенными символом новой строки

Answer 3

Вы можете попробовать:

Option Explicit

Sub test()

    Dim arr As Variant
    Dim i As Long, y As Long, Counter As Long
    Dim str As String

    str = "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Nulla purus dui, lobortis non 54leo non, feugiat venenatis urna." & _
            "Morbi lobortis ligula tincidunt 1844763, accumsan massa vel, placerat libero. In a nisl in leo lacinia 243 ullamcorper eget id tortor." & _
            "Cras vehicula malesuada luctus. Donec egestas non arcu in blandit. Donec eu lacinia ipsum, et consequat mi." & _
            "Nulla 46626 laoreet viverra purus fringilla pellentesque. Mauris sit amet pulvinar velit, at dignissim lacus." & _
            "Maecenas non sollicitudin ex. Fusce luctus enim eff43icitur aliquet finibus. Nam ac 1fermentum lacus."

    arr = Split(str, " ")

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

        Counter = 0

        For y = 1 To Len(Trim(arr(i)))

            If IsNumeric(Mid(Trim(arr(i)), y, 1)) Then

                Counter = Counter + 1

            End If

            If Counter >= 3 Then

                Debug.Print Replace(Trim(arr(i)), ",", "")
                Exit For

            End If

        Next y

    Next i

End Sub