Extract Part Of String ?

[ZORANCRO]

HOW TO EXTRACT PART OF STRING WHO IS SEPARATE BY SPACES ? (VBA )

SAMPLE:

ORIGINAL STRING ……………………………….. RESULT

LONDON 50 …………………………………….…….. 50

ZAGREB 3050 …………………………………………. 3050

RIM BB258…………………………………………....…BB258

NEW YORK HH256………………………………..……HH256

[Steven Bastiaanse]

I think this will do the job:

 

Dim oString As String

Dim sArray As Object

Dim sLast As Integer

Dim nString As String

 

'Original string input.

oString = "LONDON 50"

 

'Splits the original string.

sArray = Split(oString)

 

'Gets the last string in the array

sLast = UBound(sArray).ToString

 

'The new string

nString = sArray(sLast)

 

Greetings.

[ZORANCRO]

Steven Thank you !

 

In this part of coda occurs Error

'Gets the last string in the array

sLast = UBound(sArray).ToString

[borgunit]

Here is a very versatile trimming routine. You can set multiple parameters.

Public Function dhTrimLeft( _
   ByVal sText As String, _
   ByVal sFind As String, _
   Optional ByVal bDel As Boolean = False, _
   Optional ByVal iFirst As Integer = 1, _
   Optional ByVal fCaseSensitive As Boolean = False) As String
'------------------------------------------------------------------------------
'Trim left part of string sText up to sFind
'Arguments:
'   sText:  The text in which to search.
'   sFind:  The text for which to search.
'   bDel (default = true):  delete the text searched for
'   iFirst (Optional, default = 1):
'       An integer indicating the found occurrence count to replace. If larger
'       than the number of occurrences, replace nothing.
'       If -1, replace the final occurrence.
'   fCaseSensitive (Optional, default = False):
'       Is the search to be case-sensitive?
'Returns:
'       The input string, trimmed to the found text
'Examples:
'   dhTrimLeft("XX1234_01-130_02.dwg", "_") returns "_01-130_02.dwg"
'       because it trims left of the first occurrence.
'   dhTrimLeft("XX1234_01-130_02.dwg", "_", True) returns "01-130_02.dwg"
'       because it trims and deletes the text at the first occurrence
'   dhTrimLeft("XX1234_01-130_02.dwg", "_", False, -1) returns "_02.dwg"
'       because it trims left of the last occurrence
'   dhTrimLeft("XX1234_01-130_02.dwg", "_", True, -1) returns "02.dwg"
'       because it trims and deletes the text at the last occurrence
'   dhTrimLeft("XX1234_01-130_02.dwg", "_", True, 2) returns "02.dwg"
'       because it trims and deletes the text at the 2nd occurrence
'   dhTrimLeft("XX1234_dwg01-130_02.Dwg", "Dwg", false, 1, True) returns "dwg"
'       because it trims text at the first occurrence which matches exact case
'Requires:
'   dhCountIn
'------------------------------------------------------------------------------
Dim iLenFind As Integer
Dim iPos As Integer
Dim iStart As Integer
Dim iI As Integer
Dim iFound As Integer
Dim iMode As Integer
'''''''''''''''''''''''''''''''''''''''
On Error GoTo ErrHandler
' If anything's wrong in the various parameters,
' just exit. Unorthodox method, but it works here.
If Len(sText) = 0 Then GoTo ExitHere
If Len(sFind) = 0 Then GoTo ExitHere
If iFirst = 0 Then GoTo ExitHere

If fCaseSensitive Then
   iMode = vbBinaryCompare
Else
   iMode = vbTextCompare
End If

iFound = dhCountIn(sText, sFind, fCaseSensitive)
' The parameters must be reasonable if we're here.
' Handle the optional parameters.
If iFirst < 0 Then
   ' -1 == start at the last match.
   ' -2 == start at the next to the last match, etc.
   iFirst = iFound + iFirst + 1
   If iFirst < 1 Then iFirst = 1
End If

' Store away the length of the find to speed things up later on.
iLenFind = Len(sFind)
iPos = 1
iI = 1
Do
   iPos = InStr(iPos, sText, sFind, iMode) '1st position text is found
   If iPos > 0 Then
       ' Did you find a match? If so, check the other
       ' issues (starting replacement, and number
       ' of replacements)
       If (iI >= iFirst) Then
           ' If the current item is greater than or equal
           ' the first item the caller has requested to be replaced,
           ' and...
           ' If either you don't care about the number of
           ' replacements, or this one is less than the
           ' final one you want to make, then do it.
           
           ' Perform the replacement.
           If bDel Then
               sText = Mid$(sText, iPos + iLenFind)
               iPos = iLenFind
           Else
               sText = Mid$(sText, iPos)
'            ' Skip over the new text.
               iPos = 0
           End If
       Else
           ' Just skip over the search string.
           iPos = iPos + iLenFind
       End If
       iI = iI + 1
       ' If you know there's no more replacements, no
       ' need to continue looping. Just get on out!
       If iI > iFirst Then
           Exit Do
       End If
   End If
Loop Until iPos = 0
   
ExitHere:
   dhTrimLeft = sText
   Exit Function
   
ErrHandler:
   ' If any error occurs, just return the text as it currently is.
   Select Case Err.Number
       Case Else
           ' MsgBox "Error: " & Err.Description & " (" & Err.Number & ")"
   End Select
   Resume ExitHere
End Function
Function dhCountIn(ByVal sText As String, ByVal sFind As String, _
Optional fCaseSensitive As Boolean = False) As Integer
'------------------------------------------------------------------------------
' Determine the number of times sFind appears in sText
'Arguments:
'   sText:  Input text
'   sFind:  Text to find within sText
'   fCaseSensitive (Optional, default is False):
'       Indicates whether the search should
'       treat upper/lower case differences as
'       significant.
'Returns:   The number of times sFind appears in
'       sText, respecting the fCaseSensitive flag.
'Examples:
'   dhCountIn("This is a test", "is") returns 2
'   dhCountIn("This is a test", "s") returns 3
'Used by:
'   dhExtractCollection
'   dhCountWords
'   dhCountTokens
'   dhReplaceAll
'------------------------------------------------------------------------------
Dim iCnt As Integer
Dim iPos As Integer
Dim iMode As Integer
'''''''''''''''''''''''''''''''''''''''
' If there's nothing to find, there surely can't be any
' found, so return 0.
If Len(sFind) > 0 Then
   ' Set up the comparison mode.
   If fCaseSensitive Then
       iMode = vbBinaryCompare
   Else
       iMode = vbTextCompare
   End If
   iPos = 1
   Do
       iPos = InStr(iPos, sText, sFind, iMode)
       If iPos > 0 Then
           iCnt = iCnt + 1
           iPos = iPos + Len(sFind)
       End If
   Loop While iPos > 0
Else
   iCnt = 0
End If
dhCountIn = iCnt
End Function

[Steven Bastiaanse]

Steven Thank you !

 

In this part of coda occurs Error

'Gets the last string in the array

sLast = UBound(sArray).ToString

 

Try this:

 

Dim oString As String

Dim sArray As Object

Dim sLast As Integer

Dim nString As String

 

'Original string input.

oString = "LONDON 50"

 

'Splits the original string.

sArray = Split(oString)

 

'Gets the last string in the array

sLast = UBound(sArray)

 

'The new string

nString = sArray(sLast)