How to use VBA to extract the data after the right arrow? - excel

Question

Hello everyone,
I'm doing a challenging task assigned by my supervisor but I'm not sure how to solve this problem. The task that I want to do is to extract the values after the right arrow in column B (Input) and paste it in column C (Output). If there is only one value in the cell (e.g. B4,B8,B9,...), then the output in column C will just be the value. If the cell in column B is empty, then just leave the output column as blank. So the final output should be exactly the same as column C. May I know is there any way to achieve it using VBA scripting? I know that this can be done without using VBA, but I'm requested to use VBA to solve this problem. Any help will be greatly appreciated!

Answer 1

Try the next function, please:
Function extractValLngArrSep(str As String) As Double
Dim x: x = Split(str, " ")
'For the case of empty cell - it will return 0:
If str = "" Then extractValLngArrSep = 0: Exit Function
If UBound(x) > 0 Then
extractValLngArrSep = x(2)
Else
extractValLngArrSep = x(0)
End If
End Function
It can be tested with the next testing Sub. It can be easily applied to all column, just iterating through its cells. Now, please activate one of such a cell with separated numbers and run the code. Then one cell having a simple number:
Sub testExtractVal()
ActiveCell.Offset(0, 1).Value = extractValLngArrSep(ActiveCell.Value)
End Sub
It should be also adapted to catch the case of a single string instead of a number, but this is something out of the question and not very difficult to be handled (I think...).
To process your example range, please use the next code:
Sub testExtractValBis()
Dim sh As Worksheet, lastRow As Long, C As Range
Set sh = ActiveSheet ' please, use here your necessary sheet
lastRow = sh.Range("B" & sh.Rows.count).End(xlUp).row
For Each C In sh.Range("B3:B" & lastRow)
If C.value <> "" Then
C.Offset(0, 1).Value = extractValLngArrSep(C.Value)
End Iff
Next
End Sub

Answer 2

Extract After Character
Adjust the values in the constants section.
The Code
Option Explicit
Sub extractAfterChar()
Const wsName As String = "Sheet1"
Const srcFirst As String = "B3"
Const dstfirst As String = "C3"
Dim Delimiter As String: Delimiter = ChrW(10141)
' Define workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' Workbook containing this code.
' Declare variables
Dim rg As Range ' Source Range
Dim wrCount ' Worksheet Rows Count
' Define Source Range.
With wb.Worksheets(wsName).Range(srcFirst)
wrCount = .Worksheet.Rows.Count
Set rg = .Resize(wrCount - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious) ' Define Last Cell Range.
If rg Is Nothing Then Exit Sub ' Validate Last Cell Range.
Set rg = .Resize(rg.Row - .Row + 1) ' Define Source Range.
End With
' Write Source Range's Rows Count to a variable.
Dim rCount As Long: rCount = rg.Rows.Count
' Write values from Source Range to Data Array.
Dim Data As Variant
If rCount > 1 Then
Data = rg.Value ' multiple rows (cells)
Else
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value ' one row (cell) only
End If
' Declare additional variables.
Dim Key As Variant ' Current Value (in Data Array)
Dim i As Long ' Data Array Row Counter
' Replace values in Data Array with results.
For i = 1 To rCount
Key = Data(i, 1)
If IsError(Key) Then
Data(i, 1) = Empty
Else
If Len(Key) = 0 Then ' empty or blank ("")
Data(i, 1) = Empty
Else
Key = Val(rightString(Key, Delimiter))
If Key = 0 Then
Data(i, 1) = Empty
Else
Data(i, 1) = Key
End If
End If
End If
Next
' Write values from Data Array to Destination Range.
With wb.Worksheets(wsName).Range(dstfirst)
.Resize(wrCount - .Row + 1).ClearContents ' from first to bottom-most
.Resize(rCount).Value = Data
End With
End Sub
Function rightString( _
ByVal SearchString As String, _
Optional ByVal Delimiter As String = ",", _
Optional ByVal doTrim As Boolean = True) _
As String
Dim slen As Long: slen = Len(SearchString)
If slen = 0 Then Exit Function
Dim sPos As Long: sPos = InStr(1, SearchString, Delimiter)
If sPos > 0 Then
rightString = Right(SearchString, slen - sPos)
Else
rightString = SearchString
End If
If doTrim Then
rightString = Trim(rightString)
End If
End Function