How to Parse Based on Varying SubStrings

[SteveG]

Hello,

I have a column of data in a worksheet that I need to parse out but there is not a consistent delimiter. I would like to know how I can parse this data into 2 columns. Below is an example of my data. I have about 19 different starting strings in all that I thought I could use to determine the starting position of where I want it to be parsed. I was looking for a VBA solution to do this. Any help would be appreciated!


Thanks.


Starting String
Desired Parsing


ApplicationCode _NONSYSTEM
ApplicationCode
_NONSYSTEM


Status Out of Scope
Status
Out of Scope


Company Group Name _BLANK
Company Group Name
_BLANK


Transaction Type Complaint
Transaction Type
Complaint

[Paul_Hossler]

Well if you're lucky and the rest of the 19 values start with a defined text (like the 4 in v() below), you might make something like this work

There may be special cases that have to be handled




Option Explicit
Sub Parsing()
Dim i As Long, j As Long
Dim v As Variant
v = Array("ApplicationCode", "Status", "Company Group Name", "Transaction Type")

With ActiveSheet
For i = 1 To .Cells(1, 1).CurrentRegion.Rows.Count
For j = LBound(v) To UBound(v)
If Left(.Cells(i, 1).Value, Len(v(j))) = v(j) Then
.Cells(i, 2).Value = v(j)
.Cells(i, 3).Value = Trim(Right(.Cells(i, 1).Value, Len(.Cells(i, 1).Value) - Len(v(j))))
Exit For
End If
Next j
Next i
End With

End Sub

[mancubus]

as an alternative... starting with Paul's solution... but using array of substrings...



Sub vbax_55760_Parsing_Strings_BasedOn_Varying_SubStrings()

Dim i As Long, j As Long
Dim delimeterArr, tempArr, outArr

delimeterArr = Array("_NONSYSTEM", "Out of Scope", "_BLANK", "Complaint") 'include all substrings in the array

With Worksheets("MySheet") 'change MySheet to suit
outArr = .Cells(1).CurrentRegion.Resize(, 3)
For i = LBound(outArr) To UBound(outArr)
For j = LBound(delimeterArr) To UBound(delimeterArr)
tempArr = Split(outArr(i, 1), delimeterArr(j))
If UBound(tempArr) > 0 Then
outArr(i, 2) = tempArr(0)
outArr(i, 3) = delimeterArr(j)
Exit For
End If
Next j
Next i
.Cells(1).Resize(UBound(outArr, 1), 3) = outArr
End With

End Sub

[SamT]

Option Base 1 'Required as coded below

Dim Delimited As Variant


Sub Paul_Mancubus_SamT()
Dim i As Long
Dim Cel As Range

If IsNull(Delimited) Then Delimited_Initialize

For Each Cel In ActiveSheet.Range("A:A") 'edit Column to suit
If Cel = "" Then Exit Sub

For i = LBound(Delimited) To UBound(Delimited)
If InStr(Cel, Delimited(i, 1)) Then
If Not Delimited(i, 3) Then
InsertValues Cel, i
Else
InsertValuesTransposed Cel, i
End If
Exit For
End If
Next i
Next Cel
End Sub


Private Sub InsertValues(Target As Range, arrIndex As Long)
Dim Temp As Variant
Temp = Delimited(arrIndex)

With Target
.Offset(, 1) = Temp(1)
.Offset(, 2) = Right(Target, Len(Target) - Temp(2))
End With
End Sub


Private Sub InsertValuesTransposed(Target As Range, arrIndex As Long)
Dim Temp As Variant
Temp = Delimited(arrIndex)

With Target
.Offset(, 2) = Temp(1)
.Offset(, 1) = Left(Target, Len(Target) - Temp(2))
End With
End Sub


Private Sub Delimited_Initialize()
'Delimited(n, 1) = Search String
'Delimited(n, 2) = Position of last character of the delimiting string. (" " 0r "_")
'Delimted(n, 3) = True if Transposed. Not required unless True, default is False

ReDim Delimited(1 To 19, 1 To 3) 'Adjust size as needed

Delimited(1, 1) = "ApplicationCode"
Delimited(1, 2) = 16

Delimited(2, 1) = "Status"
Delimited(2, 2) = 8

'To be completed by OP

'Transposed example
'Value is "New Hire SamT"
'Result is "SamT" & "New Hire"
'Delimited(99, 1) = "New Hire"
'Delimited(99, 2) = 9
'Delimited(99, 3) = True


End Sub

[SteveG]

Well if you're lucky and the rest of the 19 values start with a defined text (like the 4 in v() below), you might make something like this work

There may be special cases that have to be handled




Option Explicit
Sub Parsing()
Dim i As Long, j As Long
Dim v As Variant
v = Array("ApplicationCode", "Status", "Company Group Name", "Transaction Type")

With ActiveSheet
For i = 1 To .Cells(1, 1).CurrentRegion.Rows.Count
For j = LBound(v) To UBound(v)
If Left(.Cells(i, 1).Value, Len(v(j))) = v(j) Then
.Cells(i, 2).Value = v(j)
.Cells(i, 3).Value = Trim(Right(.Cells(i, 1).Value, Len(.Cells(i, 1).Value) - Len(v(j))))
Exit For
End If
Next j
Next i
End With

End Sub



Thanks everyone for your suggestions. Paul's worked exactly as I needed it so I went with his solution. thanks again!

Steve