If the data was always in the format you present you could use the following code but I share the previous sentiments in that this may not be robust enough as the rules may not always apply. Do not run this on real data as you cannot undo VBA. I tried results with "expert report" and "deposition exhibit" (you do not have to enter the words in upper/lower case - it does not matter) and it outputs correctly. See attached workbook - there is copy of your results and a spare copy raw data for you to test it. Essentially the search terms would have to be within parentheses.
Option Explicit
Sub sepData()
Dim ws1 As Worksheet, xinStr As Integer, x As Long
Dim k As Long, iSrch As String, splStr As Variant
On Error GoTo sepData_Error
Set ws1 = Worksheets("Sheet1")
iSrch = InputBox(prompt:="Enter Search Term", Title:="Search Term")
If iSrch = vbNullString Then
Exit Sub
End If
For k = 2 To ws1.Cells(Rows.Count, "A").End(xlUp).Row
'Determine search term exists in cell
xinStr = InStr(UCase(ws1.Cells(k, 1)), UCase(iSrch))
If xinStr > 0 Then
splStr = Split(ws1.Cells(k, 1), "(")
ws1.Cells(k, 1) = vbNullString: ws1.Cells(k, 4) = vbNullString
For x = LBound(splStr) To UBound(splStr)
If InStr(UCase(splStr(x)), UCase(iSrch)) > 0 Then
ws1.Cells(k, 4) = ws1.Cells(k, 4) & "(" & splStr(x) & vbCrLf
Else
If Right(Trim(splStr(x)), 1) = ")" Then
ws1.Cells(k, 1) = ws1.Cells(k, 1) & "(" & splStr(x) & vbCrLf
Else
ws1.Cells(k, 1) = ws1.Cells(k, 1) & splStr(x) & vbCrLf
End If
End If
Next
End If
Next
On Error GoTo 0
Exit Sub
sepData_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure sepData of Module"
End Sub
Bookmarks