• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

VBA: Extract Amt from String

Hello Chihiro..

Really impressed with the short code provided by you.

I have few challenges which i have not noticed earlier.

Below are the challenges facing

upload_2017-8-12_23-17-32.png

upload_2017-8-12_23-14-23.png


Chihiro said:
Assuming following pattern is what is needed to be extracted.
digits[dot]digits

Pattern then is "\d+\.\d+". Didn't consider negative value as sample had "-550.600" but extracted as "550.600"

Code: 
Sub Demo()
Dim cel As Range
With CreateObject("VBScript.RegExp")
    .Pattern = "\d+\.\d+"
    For Each cel In Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        If .Test(cel.Value) Then cel.Offset(, 2) = CDbl(.Execute(cel.Value)(0))
    Next
End With
End Sub

If not familiar with RegEx, you can use following site to test patterns.
https://regex101.com/
Click to expand...
 
Can you upload file with all possible patterns? Original code is meant to extract number with decimal separator only.
 
FYI - If all patterns contain currency codes. It's probably easier to use that.

Ex. Below is pattern for ISO 4127 Currency Codes (simple list created from ISO documentation).
Code: 
(AED|AFN|ALL|AMD|ANG|AOA|ARS|AUD|AWG|AZN|BAM|BBD|BDT|BGN|BHD|BIF|BMD|BND|BOB|BOV|BRL|BSD|BTN|BWP|BYR|BZD|CAD|CDF|CHE|CHF|CHW|CLF|CLP|CNY|COP|COU|CRC|CUC|CUP|CVE|CZK|DJF|DKK|DOP|DZD|EGP|ERN|ETB|EUR|FJD|FKP|GBP|GEL|GHS|GIP|GMD|GNF|GTQ|GYD|HKD|HNL|HRK|HTG|HUF|IDR|ILS|INR|IQD|IRR|ISK|JMD|JOD|JPY|KES|KGS|KHR|KMF|KPW|KRW|KWD|KYD|KZT|LAK|LBP|LKR|LRD|LSL|LTL|LVL|LYD|MAD|MDL|MGA|MKD|MMK|MNT|MOP|MRO|MUR|MVR|MWK|MXN|MXV|MYR|MZN|NAD|NGN|NIO|NOK|NPR|NZD|OMR|PAB|PEN|PGK|PHP|PKR|PLN|PYG|QAR|RON|RSD|RUB|RWF|SAR|SBD|SCR|SDG|SEK|SGD|SHP|SLL|SOS|SRD|SSP|STD|SVC|SYP|SZL|THB|TJS|TMT|TND|TOP|TRY|TTD|TWD|TZS|UAH|UGX|USD|USN|USS|UYI|UYU|UZS|VEF|VND|VUV|WST|XAF|XAG|XAU|XBA|XBB|XBC|XBD|XCD|XDR|XFU|XOF|XPD|XPF|XPT|XSU|XTS|XUA|XXX|YER|ZAR|ZMW|ZWL)$
 
Hello Chihiro.

Here is the attached file with examples...Rest all looks fantastic.

Thanks for your time.
 

Attachments

  • Convert.xlsb
    15.5 KB · Views: 5
Best solution but only thing is i need to mention the currencies unlimited..

but really works for all my challenges.


Code: 
Private Sub Get_Sums()
    Application.ScreenUpdating = False
    On Error Resume Next
    With ActiveSheet
        Dim chks(3)
        chks(0) = "USD."
        chks(1) = "USD-"
        chks(2) = "GPB:"
        chks(3) = ".CNY"
        y = 2
        Do
            .Cells(y, 3) = Empty
            chk_a = .Cells(y, 1)
            For c = 0 To 3
                Err.Clear
                cutX = WorksheetFunction.Find(chks(c), chk_a, 1)
                If Err.Number = 0 Then
                    .Cells(y, 3) = Mid(chk_a, cutX + 4, 12)
                    .Cells(y, 3).NumberFormat = "0.000"
                    c = 99
                End If
            Next c
            y = y + 1
        Loop Until .Cells(y, 1) = Empty
    End With
    Application.ScreenUpdating = True
    MsgBox "DONE"
End Sub
vletm said:
Something like this ?
There were 4 kind of 'amounts', none negative(?).
Press [GET]
Click to expand...
 
What system is this data taken from? Never seen this bad of pattern inconsistency from single source.

At any rate, try below.
Code: 
Sub Demo()
Dim myArr
myArr = Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row).Value

For i = 1 To UBound(myArr)
    For j = Len(myArr(i, 1)) To 1 Step -1
        tVal = Mid(myArr(i, 1), j, 1)
        If IsNumeric(tVal) Or tVal = "." Then
            res = tVal & res
        ElseIf tVal = "," Then
        Else
            With CreateObject("VBScript.RegExp")
                .Pattern = "(USD|GPB|CNY)"
                If Not .Test(myArr(i, 1)) Then
                    myArr(i, 1) = ""
                    res = ""
                    Exit For
                Else
                    myArr(i, 1) = IIf(InStr(1, res, ".") = 1, Replace(res, ".", "", 1, 1), res)
                    res = ""
                    Exit For
                End If
            End With
        End If
    Next
Next

Range("C2").Resize(UBound(myArr)) = myArr
           
End Sub
 
Monty
You haven't send more data or have You?
My '#31' code has made just from You original data; seven rows.
If You could sent more data then You could get another code which would have more currencies.
 
Chihiro said:
Assuming following pattern is what is needed to be extracted.
digits[dot]digits

Pattern then is "\d+\.\d+". Didn't consider negative value as sample had "-550.600" but extracted as "550.600"

Code: 
Sub Demo()
Dim cel As Range
With CreateObject("VBScript.RegExp")
    .Pattern = "\d+\.\d+"
    For Each cel In Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        If .Test(cel.Value) Then cel.Offset(, 2) = CDbl(.Execute(cel.Value)(0))
    Next
End With
End Sub

If not familiar with RegEx, you can use following site to test patterns.
https://regex101.com/
Click to expand...

This is the best could I believe with using any currency s
 
Chihiro said:
What system is this data taken from? Never seen this bad of pattern inconsistency from single source.

At any rate, try below.
Code: 
Sub Demo()
Dim myArr
myArr = Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row).Value

For i = 1 To UBound(myArr)
    For j = Len(myArr(i, 1)) To 1 Step -1
        tVal = Mid(myArr(i, 1), j, 1)
        If IsNumeric(tVal) Or tVal = "." Then
            res = tVal & res
        ElseIf tVal = "," Then
        Else
            With CreateObject("VBScript.RegExp")
                .Pattern = "(USD|GPB|CNY)"
                If Not .Test(myArr(i, 1)) Then
                    myArr(i, 1) = ""
                    res = ""
                    Exit For
                Else
                    myArr(i, 1) = IIf(InStr(1, res, ".") = 1, Replace(res, ".", "", 1, 1), res)
                    res = ""
                    Exit For
                End If
            End With
        End If
    Next
Next

Range("C2").Resize(UBound(myArr)) = myArr
          
End Sub
Click to expand...

Thanks for your efforts...But to mention all the available currency s....In the code... Trying to find modified short code you provided where you have mentioned currencies...
 
Then use this.

Code: 
Sub Demo()
Dim myArr
myArr = Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row).Value

For i = 1 To UBound(myArr)
    For j = Len(myArr(i, 1)) To 1 Step -1
        tVal = Mid(myArr(i, 1), j, 1)
        If IsNumeric(tVal) Or tVal = "." Then
            res = tVal & res
        ElseIf tVal = "," Then
        ElseIf tVal = " " Then
                myArr(i, 1) = ""
                res = ""
                Exit For
        Else
                myArr(i, 1) = IIf(InStr(1, res, ".") = 1, Replace(res, ".", "", 1, 1), res)
                res = ""
                Exit For
        End If
    Next
Next

Range("C2").Resize(UBound(myArr)) = myArr
           
End Sub

Note: In your sample there is no space after currency code so it works. If there is instance where currency code is followed by a space before the amount. This will fail.
 
Also this using RegEx.
Code: 
Sub Demo()
Dim myArr, i As Long
myArr = Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row).Value

With CreateObject("VBScript.RegExp")
    .Pattern = "(\d+\.\d+|\d+\.|-\d+)$"
    .Global = True
    For i = 1 To UBound(myArr)
        myArr(i, 1) = Replace(myArr(i, 1), ",", "")
        If .Test(myArr(i, 1)) Then
            myArr(i, 1) = Replace(.Execute(myArr(i, 1))(0), "-", "")
        Else
            myArr(i, 1) = ""
        End If
    Next
End With
Range("C2").Resize(UBound(myArr)) = myArr
End Sub

Again if pattern changes from your sample, you will likely need to modify it.
 
Wow chihiro...You are awsome without currency code mentioning we are able to get the results but it fails at only one point.

DEBIT-HSEP HTA-DEVELOPMENT 2017-04.USD530

for the above case no result and these kind of lines are many in the raw data...can you please help me.


Chihiro said:
Also this using RegEx.
Code: 
Sub Demo()
Dim myArr, i As Long
myArr = Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row).Value

With CreateObject("VBScript.RegExp")
    .Pattern = "(\d+\.\d+|\d+\.|-\d+)$"
    .Global = True
    For i = 1 To UBound(myArr)
        myArr(i, 1) = Replace(myArr(i, 1), ",", "")
        If .Test(myArr(i, 1)) Then
            myArr(i, 1) = Replace(.Execute(myArr(i, 1))(0), "-", "")
        Else
            myArr(i, 1) = ""
        End If
    Next
End With
Range("C2").Resize(UBound(myArr)) = myArr
End Sub

Again if pattern changes from your sample, you will likely need to modify it.
Click to expand...
 
So that's a new pattern not found in your sample.

This is going to add extra layer of complexity, since pattern \d+ is going to match both of following.

FOR S115 PROPERTY ACC FOR JUNE 2017
DEBIT-HSEP HTA-DEVELOPMENT 2017-04.USD530

Since, you don't want to list patterns for currency code... You could add pattern [A-Z]\d+, but that's going to extract D530, and requires additional check/process in code.

Just use the code in post #37, that one will accommodate for your new pattern.

If you really must use RegEx... try something like...

Code: 
Sub Demo()
Dim myArr, i As Long
myArr = Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row).Value

With CreateObject("VBScript.RegExp")
    .Pattern = "(\d+\.\d+|\d+\.|-\d+|[A-Z]\d+)$"
    .Global = True
    For i = 1 To UBound(myArr)
        myArr(i, 1) = Replace(myArr(i, 1), ",", "")
        If .Test(myArr(i, 1)) Then
            If IsNumeric(Left(.Execute(myArr(i, 1))(0), 1)) Then
                Debug.Print i & "," & Left(.Execute(myArr(i, 1))(0), 1)
                myArr(i, 1) = .Execute(myArr(i, 1))(0)
            ElseIf Left(.Execute(myArr(i, 1))(0), 1) <> " " Then
                myArr(i, 1) = Replace(.Execute(myArr(i, 1))(0), Left(.Execute(myArr(i, 1))(0), 1), "")
            End If
        Else
            myArr(i, 1) = ""
        End If
    Next
End With
Range("C2").Resize(UBound(myArr)) = myArr
End Sub
 
You must log in or register to reply here.
Back
Top