Excel VBA RegEx, который извлекает числа из ценовых значений в диапазоне (имеет запятые, $ и -)

Question

У меня есть данные поля, извлеченные из базы данных, которая представляет диапазон значений, но они поступают в Excel в виде строкового формата $86,000 - $162,000.

Мне нужно извлечь минимальное значение и максимальное значение изкаждой ячейке, поэтому мне нужно извлечь ее числовую часть и игнорировать $, - и ,.

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

Это самый близкий образец, который я получил с RegEx , но я не то, что я ищу.

Pattern = (\d+)(?:\.(\d{1,2}))?

Кто-нибудь может помочь?

Answer 1

Вы даже можете сделать это с помощью формул листа.При определенных обстоятельствах Excel будет игнорировать $ и ,.Двойное унарное преобразование возвращаемой строки в числовое значение.

First Value:  =--LEFT(A1,FIND("-",A1)-1)
Second Value: =--MID(A1,FIND("-",A1)+1,99)

Answer 2

Без цикла (но все еще без регулярных выражений):

Sub Split()
    With Columns("B:B")
        .Replace What:="$", Replacement:=""
        Application.CutCopyMode = False
        .TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, Other:=True, OtherChar:="-", FieldInfo:=Array(Array(1, 1), Array(2, 1))
    End With
    Columns("B:C").Insert Shift:=xlToRight
    Columns("D:E").NumberFormat = "0"
    Range("D1").FormulaR1C1 = "Min Value"
    Range("E1").FormulaR1C1 = "Max Value"
    With Range("D1:E1").Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 12611584
    End With
    With Range("D1:E1").Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
End Sub

Answer 3

Вот пример быстрого примера https://regex101.com/r/RTNlVF/1

Pattern "^\$(\d+\,\d+)\s\-\s\$(\d+\,\d+)"

Option Explicit
Private Sub Example()
    Dim RegExp As New RegExp
    Dim Pattern As String
    Dim CelValue As String
    Dim rng As Range
    Dim Cel As Range

    Set rng = ActiveWorkbook.Sheets("Sheet1" _
                            ).Range("A2", Range("A9999" _
                            ).End(xlUp))

    For Each Cel In rng
        DoEvents
        Pattern = "^\$(\d+\,\d+)\s\-\s\$(\d+\,\d+)"

        If Pattern <> "" Then
            With RegExp
                .Global = True
                .MultiLine = True
                .IgnoreCase = False
                .Pattern = Pattern
            End With

            If RegExp.Test(Cel.Value) Then
'                Debug.Print Cel.Value

                Debug.Print RegExp.Replace(CStr(Cel), "$1")
                Debug.Print RegExp.Replace(CStr(Cel), "$2")

            End If
        End If
    Next
End Sub

Answer 4

Я сделал эту функцию:

Надеюсь, это поможет.Код:

Function ExtractNumber(ByVal TextInput As String, _
Optional ByVal Position As Byte = 0, _
Optional ByVal Delimiter As String = "-") As Variant
'   You can use this function in a subprocess that
'   writes the values in the cells you want, or
'   you can use it directly in the ouput cells

'   Variables
    Dim RemoveItems(2) As String
    Dim Aux As Variant

'   The variable RemoveItems is an array
'   containing the characters you want to remove
    RemoveItems(0) = "."
    RemoveItems(1) = ","
    RemoveItems(2) = " "

'   STEP 1 - The variable Aux will store the text
'   given as input
    Aux = TextInput

'   STEP 2 - Characters stored in the variable
'   RemoveItems will be removed from Aux
    For i = 0 To UBound(RemoveItems)

        Aux = Replace(Aux, RemoveItems(i), "")

    Next i

'   STEP 3 - Once Aux is "clean", it will be
'   transformed into an array containing the
'   values separated by the delimiter

'   As you can see at the function's header,
'   Delimiter default value is "-". You can change
'   it depending on the situation
    Aux = Split(Aux, Delimiter)

'   STEP 4 - The result of this function will be
'   a numeric value. So, if the value of the
'   selected position in Aux is not numeric it will
'   remove the first character assuming it is a
'   currency symbol.

'   If something fails in the process the function
'   will return "ERROR", so you can know you may
'   verify the inputs or adjust this code for
'   your needs.

On Error GoTo ErrHndl

    If Not IsNumeric(Aux(Position)) Then

        ExtractNumber = CLng(Mid(Aux(Position), 2))

    Else

        ExtractNumber = CLng(Aux(Position))

    End If

    Exit Function

ErrHndl:

    ExtractNumber = "ERROR"

End Function

Answer 5

Просто интересно, почему Regex?

Function GetParts(priceRange As String) As Double()
    Dim arr() As String
    Dim parts() As Double

    If InStr(1, priceRange, "-") > 0 Then
        arr = Split(priceRange, "-")
        ReDim parts(0 To UBound(arr))

        Dim i As Long
        For i = 0 To UBound(arr)
            parts(i) = CDbl(Replace$(Replace$(Trim$(arr(i)), "$", ""), ",", ""))
        Next i
    End If
    GetParts = parts
End Function

Sub test()
 MsgBox GetParts("$14,000 - $1,234,567")(0)   'Minimum
End Sub

РЕДАКТИРОВАТЬ

Тем не менее, вы можете сделать это с помощью regex, чтобы сопоставить строку данных с частями:

Function GetPartsRegEx(priceRange As String) As Variant
    Dim arr() As Double

    Dim pricePattern As String
    pricePattern = "(\$?\d+[\,\.\d]*)"

    'START EDIT 
    Static re As RegExp
    If re Is Nothing Then
        Set re = New RegExp
        re.IgnoreCase = True
        re.Global = True
        re.Pattern = pricePattern & "\s*[\-]\s*" & pricePattern   'look for the pattern first
    End If

    Static nums As RegExp
    If nums Is Nothing Then
        Set nums = New RegExp
        'to remove all non digits, except decimal point in case you have pennies
        nums.Pattern = "[^0-9.]"    
        nums.Global = True
    End If
    'END EDIT

    If re.test(priceRange) Then
        ReDim arr(0 To 1)   ' fill return array
        arr(0) = CDbl(nums.Replace(re.Replace(priceRange, "$1"), ""))
        arr(1) = CDbl(nums.Replace(re.Replace(priceRange, "$2"), ""))
    Else
        'do some error handling here
        Exit Function
    End If  'maybe throw error if no +ve test or

    GetPartsRegEx = arr
End Function

Sub test()
    MsgBox GetPartsRegEx("$1,005.45 - $1,234,567.88")(1)
End Sub