Extracting Text from Cell using Excel VBA

2020-04-08 excel vba

I am looking to extract multiple text values from a column in Excel and populate another column with these text values.

To be more specific, I am looking to extract the STLS ticket numbers.

For example, one row may contain "ABCD-4, STLS-5644, ABBD-33, STLS-421", another row may contain "ABB-567, STLS-56435" and another row may contain no STLS tickets.

What would be the best way to approach this problem?


You could try this code:

Option Explicit

Sub testExtract()

  Dim i As Long, j As Long, jUp As Long, lFirstRow As Long, lLastRow As Long
  Dim lColFrom As Long, lColTo As Long, nTicks As Long
  Dim str1 As String

  Dim varArray

  ' define source column number and the destination one:
  lColFrom = 1
  lColTo = 2

  ' initialize range to analyze:
  lFirstRow = 1
  lLastRow = Cells(Rows.Count, 1).End(xlUp).Row

  ' loop over the rows:
  For i = lFirstRow To lLastRow
    ' split the string in the cell in an array:
    varArray = Split(Cells(i, lColFrom).Value, ",")
    jUp = UBound(varArray)
    nTicks = 0
    str1 = ""
    ' check the array element by element if we have some ticket:
    For j = 0 To jUp
      ' trim spaces:
      varArray(j) = Trim(varArray(j))

      ' check if we have ticks and count them:
      If (InStr(1, varArray(j), "STLS-") > 0) Then
        If (nTicks > 0) Then
          str1 = str1 & ", "
        End If
        str1 = str1 & varArray(j)
        nTicks = nTicks + 1
      End If

    ' save ticks:
    If (str1 <> "") Then
      Cells(i, lColTo).Value = str1
    End If


End Sub

Capture of screen

If your Excel has the FILTERXML function (windows Excel 2013+) and the TEXTJOIN function, you don't need VBA.

You can use:

=IFERROR(TEXTJOIN(",",TRUE,FILTERXML("<t><s>" & SUBSTITUTE(A1,",","</s><s>")&"</s></t>","//s[contains(.,'STLS')]")),"")

enter image description here

If you don't have those functions, you can use this VBA UDF:

Option Explicit
Function getTickets(s As String, ticket As String) As String
    Dim v, w, x, col As Collection, i As Long
v = Split(s, ",")
Set col = New Collection
For Each w In v
    If Trim(w) Like ticket & "*" Then col.Add Trim(w)
Next w

i = 0

If col.Count = 0 Then
    getTickets = ""
    ReDim x(col.Count - 1)
    For Each w In col
        x(i) = w
        i = i + 1
    Next w
    getTickets = Join(x, ",")
End If
End Function