Extract amounts from text strings using VBA

[bdb91]

Hello experts,
Seeking for your help in fixing a macro which should extract amounts from text strings in thefirst column on the current sheet.
The format of amounts is like this: 15´068.20
Strings consist also other numeric signs which are not amounts, e.g. field numbers like 2.2 or zip codes like 3284 etc. In addition to it amounts are not always in the beginning of the string. There are two elements which can help to identify amounts: 1) a separator ´ and 2) a decimal piont with following two numbers in the end like .00
I wrote followingcode which should extract numbers:


Sub Test9()
Dim i As Long
Dim j As Long
Dim AmountValue As String

For i = 1 To Rows.Count
If InStr(Cells(i, 1).Value, ".") > 0 And IsNumeric(Mid(Cells(i, 1), InStr(Cells(i, 1).Value, ".") + 1, 2)) = True And Not (Mid(Cells(i, 1), InStr(Cells(i, 1).Value, ".") + 2, 1)) = " " Then
Do While IsNumeric(Mid(Cells(i, 1), InStr(Cells(i, 1).Value, ".") - 1, 1)) = True Or Mid(Cells(i, 1), InStr(Cells(i, 1).Value, ".") - 1, 1) = "´"
DoEvents
j = 0
AmountValue = Mid(Cells(i, 1), InStr(Cells(i, 1).Value, ".") - 1, 4 + j)
j = j + 1

Loop

Cells(i, 5).Value = AmountValue
End If

Next i
End Sub

The problem withthis code is that when macro runs I will see NOT RESPONDING in top ofExcel VBA and Excel doesn't respond anymore. I added DoEvents into the code. It helps to avoid Excel freezing but the macro getting stuck anyways and doesn’t return any values.
Any suggestionshow to optimise the code that it works?
Thanks a lot inadvance!

[Paul_Hossler]

"For i = 1 To Rows.Count" tells Excel to start at 1 and go to row 1,048,576 on the active sheet so it's busy

Try to set the loop to just the cells where there's data

Example -- not tested





Option Explicit

Sub Test9()
Dim i As Long
Dim j As Long
Dim AmountValue As String, sTemp As String
Dim r As Range

Set r = Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp))

For i = 1 To r.Rows.Count

sTemp = r.Cells(i, 1).Value

If InStr(sTemp, ".") > 0 And IsNumeric(Mid(sTemp, InStr(sTemp, ".") + 1, 2)) = True And Not (Mid(sTemp, InStr(sTemp, ".") + 2, 1)) = " " Then
Do While IsNumeric(Mid(sTemp, InStr(sTemp, ".") - 1, 1)) = True Or Mid(sTemp, InStr(sTemp, ".") - 1, 1) = "?"
DoEvents
j = 0
AmountValue = Mid(sTemp, InStr(sTemp, ".") - 1, 4 + j)
j = j + 1
Loop

Cells(i, 5).Value = AmountValue
End If

Next i
End Sub

[bdb91]

Hi Paul,
Thank you, good idea indeed.
I just have tried with the updated code but the result is the same. I tried both with DoEvents and without.
So, seems it doesn’t change much in productivity of excel in this case.

[Paul_Hossler]

Post a small workbook with some data and your current macro

Do all number strings have the ' seperator or only those over 1000?

Your seperator character in your first post is an ASCII 180. Is that correct?


Maybe something like this as a starting point?



Option Explicit

Sub Test10()
Dim i As Long, j As Long
Dim AmountValue As String, sTemp As String
Dim r As Range


Set r = Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp))

For i = 1 To r.Rows.Count
sTemp = Trim(r.Cells(i, 1).Value)

If Not Right(sTemp, 3) Like ".##" Then GoTo GetNext

AmountValue = vbNullString
For j = Len(sTemp) To 1 Step -1
Select Case Mid(sTemp, j, 1)
Case 0 To 9, Chr(180), "."
AmountValue = Mid(sTemp, j, 1) & AmountValue
Case Else
Exit For
End Select
Next j
ActiveSheet.Cells(i, 5).Value = AmountValue
GetNext:

Next i
End Sub

[bdb91]

Hi Paul,
Thank you a lot!!

It works - the amounts are extracted. There is a problem only if there is some text after amount on the right side but I will try to fix it now.

Yes, only those number strings have the ' seperator which are over 1000. And the seperator is ASCII 180.

[Paul_Hossler]

This is what I came up with




Option Explicit

Sub Test10()
Dim i As Long, j As Long, iDotNumberNumber As Long
Dim AmountValue As String, sTemp As String
Dim r As Range
Set r = Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp))

For i = 1 To r.Rows.Count
sTemp = Trim(r.Cells(i, 1).Value)

If InStr(sTemp, ".") = 0 Then GoTo GetNext


For j = 1 To Len(sTemp) - 2
If Mid(sTemp, j, 3) Like ".##" Then
iDotNumberNumber = j + 2
Exit For
End If
Next j

AmountValue = vbNullString
For j = iDotNumberNumber To 1 Step -1
Select Case Mid(sTemp, j, 1)
Case 0 To 9, Chr(180), "."
AmountValue = Mid(sTemp, j, 1) & AmountValue
Case Else
Exit For
End Select
Next j
ActiveSheet.Cells(i, 5).Value = AmountValue
GetNext:
Next i
End Sub

[bdb91]

Hi Paul,
It works perfectly! I am very grateful for your help!