• 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

Monty

Well-Known Member
Hello Everyone.

Little tricky one tried all the combinations including text to columns and with vba for the below attached file.

I have 85 k rows need to loop through each row to get the output only the amount.

Taken sample text which is most commonly repeated onces in my data.

It would be great if we can crack. Thanks.

upload_2017-7-24_23-39-44.png
 

Attachments

  • Convert.xlsb
    8.4 KB · Views: 19
Hey vletm..

Hope you are doing good..

There are 4 type as per the sample i investigated it may be more...but lukly all the amounts will be at the end of the string...

for some strings there is no amount..

in attached file ....Macro missing in the file...
 
Really like the code written smart and quick..

But this may not be the case always

chks(0) = "USD." ' What if GPB having only dot.
chks(1) = "USD-" ;What if USD have colon.
chks(2) = "GPB:" ' What if CNY having space
chks(3) = ".CNY"

Just wanted to understand...how we can tweek this!
 
Hello Mr. Monty
Here's my poor attempt.. Till experts offer more
Code:
Sub Test()
    Dim arr        As Variant
    Dim x          As Variant
    Dim str        As String
    Dim i          As Long

    arr = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row).Resize(, 2).Value

    For i = LBound(arr, 1) To UBound(arr, 1)
        If InStr(arr(i, 1), "USD") > 0 Then
            str = "USD"
        ElseIf InStr(arr(i, 1), "GPB") > 0 Then
            str = "GPB"
        ElseIf InStr(arr(i, 1), "CNY") > 0 Then
            str = "CNY"
        Else
            str = ""
        End If

        If str <> "" Then x = ExtractNumber(CStr(Split(arr(i, 1), str)(1)), 1): arr(i, 2) = CStr(x)
    Next i

    Range("A2").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End Sub

Function ExtractNumber(rCell, Optional Take_decimal As Boolean, Optional Take_negative As Boolean) As Double
    Dim vVal        As Variant
    Dim vVal2      As Variant
    Dim iCount      As Integer
    Dim i          As Integer
    Dim iLoop      As Integer
    Dim sText      As String
    Dim strNeg      As String
    Dim strDec      As String
    Dim lNum        As String

    sText = rCell

    If Take_decimal = True And Take_negative = True Then
        strNeg = "-"
        strDec = "."
    ElseIf Take_decimal = True And Take_negative = False Then
        strNeg = vbNullString
        strDec = "."
    ElseIf Take_decimal = False And Take_negative = True Then
        strNeg = "-"
        strDec = vbNullString
    End If

    iLoop = Len(sText)
    For iCount = iLoop To 1 Step -1
        vVal = Mid(sText, iCount, 1)
        If IsNumeric(vVal) Or vVal = strNeg Or vVal = strDec Then
            i = i + 1
            lNum = Mid(sText, iCount, 1) & lNum

            If IsNumeric(lNum) Then
                If CDbl(lNum) < 0 Then Exit For
            Else
                lNum = Replace(lNum, Left(lNum, 1), "", , 1)
            End If
        End If

        If i = 1 And lNum <> vbNullString Then lNum = CDbl(Mid(lNum, 1, 1))
    Next iCount

    ExtractNumber = CDbl(lNum)
End Function
 
Monty
You can add as many those as needed.
Just modify code as needed.
I pick those from Your sample!
If 'something' gotta find then 'something' gotta know!
There have to be rules!
... and as I wrote, Your sample shows that NO negative amounts!
 
Monty
You can add as many those as needed.
Just modify code as needed.
I pick those from Your sample!
If 'something' gotta find then 'something' gotta know!
There have to be rules!
... and as I wrote, Your sample shows that NO negative amounts!
Yes...Thank you so very much!...need to investigate how many currency available and implement code provided...Will surly get back to you on this...Awsome!
 
YasserKhalil...This is really a poor attempt..But made my day Awesome code...works like a charm...Tried with all the combinations to see whether it works..No words..You are champ.

Will check at work...how many currency available based on the historic data to crack this.Onces again thank you so very much!



Hello Mr. Monty
Here's my poor attempt.. Till experts offer more
Code:
Sub Test()
    Dim arr        As Variant
    Dim x          As Variant
    Dim str        As String
    Dim i          As Long

    arr = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row).Resize(, 2).Value

    For i = LBound(arr, 1) To UBound(arr, 1)
        If InStr(arr(i, 1), "USD") > 0 Then
            str = "USD"
        ElseIf InStr(arr(i, 1), "GPB") > 0 Then
            str = "GPB"
        ElseIf InStr(arr(i, 1), "CNY") > 0 Then
            str = "CNY"
        Else
            str = ""
        End If

        If str <> "" Then x = ExtractNumber(CStr(Split(arr(i, 1), str)(1)), 1): arr(i, 2) = CStr(x)
    Next i

    Range("A2").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End Sub

Function ExtractNumber(rCell, Optional Take_decimal As Boolean, Optional Take_negative As Boolean) As Double
    Dim vVal        As Variant
    Dim vVal2      As Variant
    Dim iCount      As Integer
    Dim i          As Integer
    Dim iLoop      As Integer
    Dim sText      As String
    Dim strNeg      As String
    Dim strDec      As String
    Dim lNum        As String

    sText = rCell

    If Take_decimal = True And Take_negative = True Then
        strNeg = "-"
        strDec = "."
    ElseIf Take_decimal = True And Take_negative = False Then
        strNeg = vbNullString
        strDec = "."
    ElseIf Take_decimal = False And Take_negative = True Then
        strNeg = "-"
        strDec = vbNullString
    End If

    iLoop = Len(sText)
    For iCount = iLoop To 1 Step -1
        vVal = Mid(sText, iCount, 1)
        If IsNumeric(vVal) Or vVal = strNeg Or vVal = strDec Then
            i = i + 1
            lNum = Mid(sText, iCount, 1) & lNum

            If IsNumeric(lNum) Then
                If CDbl(lNum) < 0 Then Exit For
            Else
                lNum = Replace(lNum, Left(lNum, 1), "", , 1)
            End If
        End If

        If i = 1 And lNum <> vbNullString Then lNum = CDbl(Mid(lNum, 1, 1))
    Next iCount

    ExtractNumber = CDbl(lNum)
End Function
 
Yes Boss.
Going to be easy to adopt currencies as you said...But just thinking instead of investigating what other currencies available...Better to include all the currencies. To be safe side.

But again If condition is going to lengthy one....May be need use some array to store all...?

Your code is Masterpiece!
 
Monty
1) Are You sure that those 'String'-parts do not have texts like 'USD' or any other currency are You? That's why those 'mystic' pre/past characters would be need.
2) Your sample shows that no negative amounts!
3) Just one if condition needs to find which currency (or of course many if want to do so).
4) Send those 85k rows here, then You could see how to get those amounts out!
 
Hi !

With a complete and crystal clear presentation,
maybe an easy way is possible without taking care of any currency …

All numbers to extract have a dot ?

Way 1 : check from end of string first character which is not a number
or a second dot. If is it not the last character and different from a space,
so there is a number to extract …

Way 2 : use a regular expression …
 
Marc L - hmm ..
1) like from end of strings form sample data:
FOR JUNE 2017
2017-04.CNY46874.102896

2) As I wrote:

Are You sure that those 'String'-parts do not have texts like 'USD' or any other currency...?
>> Without data ... challenge!
 

No issue on my side with sample workbook, just follow way 1 logic,
that needs around 30 codelines without checking any currency …​
 
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/
 

Way 2 in previous post, for advanced users.

Way 1 is a child logic so at beginner level …
 
I'm not so sure that RegEx is for advanced users. It really does, simplify coding logic and is quite simple to use.

For the other way, I'd likely do something like below.
Code:
Sub Demo()
Dim cel As Range, x As String
For Each cel In Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
    For i = Len(cel.Value) To 1 Step -1
        If IsNumeric(Mid(cel.Value, i, 1)) Or Mid(cel.Value, i, 1) = "." Then
            If Mid(cel.Value, i, 1) = "." Then
                x = IIf(InStr(1, x, ".") > 0, "" & x, Mid(cel.Value, i, 1) & x)
            Else
                x = Mid(cel.Value, i, 1) & x
            End If
        Else
            Exit For
        End If
    Next
    If InStr(1, x, ".") > 0 Then
        cel.Offset(, 2) = CDbl(x)
    End If
    x = ""
Next
End Sub
 
This could make many ways, correct.
But many things depends about that data and wanted output.
'Short data' and ... clear output.
As I have tried to verify from the #2 Reply.
Original wanted output has only positive amounts (550.600 or -550.6).
Screen Shot 2017-07-27 at 11.13.04.png
Screen Shot 2017-07-27 at 11.13.17.png
I 'think' that is mistake, but wanted is wanted!
Other, what would miss from original output is that 'Currency'-code.
That was't wanted ... but is output useful without it ...only one knows.
I cannot use Power Query, that's why nice to see how to use it too.
Thank You.
 
Back
Top