VBA - Search for strings then copy strings (+ text up to delimiter) and join in another column

[spidaman]

Can anyone help with this please?

I have a column where cells contain strings separated by the delimiter ';'
For each cell, if it contains certain strings I'd like to copy the strings and the associated characters up to the delimiter into column Offset(0,1) or Offset(0,2) depending on the string.
In many cases there are more than one string in the same cell (so MyStr1 and MyStr3 for example). If so I want to join them with a forward slash ' / '

Please see the example below:

Dim MyStr1 As String, MyStr2 As String, MyStr3 AS String

MyStr1 = "Fin: "
MyStr2 = "Called (Same): "
MyStr3 = "Called: "

If cell contains MyStr1 I want to copy MyStr1 and the characters up to the first ';' into cell Offset(0,1).
If cell contains MyStr2 or MyStr3 I want to copy both strings with the characters up to the first ';' into cell Offset(0,2) with MyStr2 and MyStr3 separated by ' / '.

Here is an example of the cell contents:

Fin: +123456789;Called (Same): Robert Jones;Called: Rob Jonez

In this case I'd like to copy MyStr1 and the characters up to the first ';' into Offset(0,1) and copy MyStr2 and MyStr3 with characters up to the ';' into Offset(0,2) separated by ' /'.

Note that there is never a delimiter ';' at the end of the string in any cell.

I am trying to avoid coding this using text-to-columns due to unpredictable number of the strings existing.

Any help with this is very much appreciated in advance.

 

[John_w]

Try this:

Sub Search_Cells()

    Dim MyStr1 As String, MyStr2 As String, MyStr3 As String
    Dim searchCell As Range
    Dim p1 As Long, p2 As Long

    For Each searchCell In Range("A1:A10")

        MyStr1 = "Fin: "
        p1 = InStr(searchCell.Value & ";", MyStr1)
        If p1 > 0 Then
            p2 = InStr(p1, searchCell.Value, ";")
            searchCell.Offset(, 1).Value = Mid(searchCell.Value, p1, p2 - p1)
        End If
        
        MyStr2 = "Called (Same): "
        p1 = InStr(searchCell.Value & ";", MyStr2)
        If p1 > 0 Then
            p2 = InStr(p1, searchCell.Value, ";")
            searchCell.Offset(, 2).Value = Mid(searchCell.Value, p1, p2 - p1)
        End If
        
        MyStr3 = "Called: "
        p1 = InStr(searchCell.Value, MyStr3)
        If p1 > 0 Then
            p2 = InStr(p1, searchCell.Value & ";", ";")
            If IsEmpty(searchCell.Offset(, 2).Value) Then
                searchCell.Offset(, 2).Value = Mid(searchCell.Value, p1, p2 - p1)
            Else
                searchCell.Offset(, 2).Value = searchCell.Offset(, 2).Value & " / " & Mid(searchCell.Value, p1, p2 - p1)
            End If
        End If
        
    Next

End Sub

 

[spidaman]

Thanks for your help with this John_w

At the moment it's throwing an error 5 on this line:

searchCell.Offset(, 2).Value = Mid(searchCell.Value, p1, p2 - p1)

from the MyStr2 section.

I should have mentioned that there could be multiple occurrences for some of the strings within a cell. For example MyStr3 can occur 3 times in one cell (still split by ';'). In these cases I'd still like to copy the string and associated characters into Offset(,2).

Any thoughts?

 

[John_w]

The error occurs because p2 = 0, because the previous line should be:

p2 = InStr(p1, searchCell.Value & ";", ";")

This should work for multiple occurrences of MyStr1, 2 and 3:

Sub Search_Cells()

    Dim MyStr1 As String, MyStr2 As String, MyStr3 As String
    Dim searchCell As Range, searchCellValue As String
    Dim p1 As Long, p2 As Long
    
    For Each searchCell In Range("A1:A10")  'change range as needed
    
        searchCellValue = searchCell.Value & ";"
        
        searchCell.Offset(, 1).Clear
        MyStr1 = "Fin: "
        p1 = 1
        Do
            p1 = InStr(p1, searchCellValue, MyStr1)
            If p1 > 0 Then
                p2 = InStr(p1, searchCellValue, ";")
                If IsEmpty(searchCell.Offset(, 1).Value) Then
                    searchCell.Offset(, 1).Value = Mid(searchCellValue, p1, p2 - p1)
                Else
                    searchCell.Offset(, 1).Value = searchCell.Offset(, 1).Value & " / " & Mid(searchCellValue, p1, p2 - p1)
                End If
                p1 = p2
            End If
        Loop Until p1 = 0
        
        searchCell.Offset(, 2).Clear
        MyStr2 = "Called (Same): "
        p1 = 1
        Do
            p1 = InStr(p1, searchCellValue, MyStr2)
            If p1 > 0 Then
                p2 = InStr(p1, searchCellValue, ";")
                If IsEmpty(searchCell.Offset(, 2).Value) Then
                    searchCell.Offset(, 2).Value = Mid(searchCellValue, p1, p2 - p1)
                Else
                    searchCell.Offset(, 2).Value = searchCell.Offset(, 2).Value & " / " & Mid(searchCellValue, p1, p2 - p1)
                End If
                p1 = p2
            End If
        Loop Until p1 = 0
        
        MyStr3 = "Called: "
        p1 = 1
        Do
            p1 = InStr(p1, searchCellValue, MyStr3)
            If p1 > 0 Then
                p2 = InStr(p1, searchCellValue, ";")
                If IsEmpty(searchCell.Offset(, 2).Value) Then
                    searchCell.Offset(, 2).Value = Mid(searchCellValue, p1, p2 - p1)
                Else
                    searchCell.Offset(, 2).Value = searchCell.Offset(, 2).Value & " / " & Mid(searchCellValue, p1, p2 - p1)
                End If
                p1 = p2
            End If
        Loop Until p1 = 0
        
    Next

End Sub

 

[spidaman]

Thank you very much, this is working perfectly.

Your time is much appreciated.