Extract a string of text from a cell

[RattlingCarp3048]

this one is tripping me up big time. via formula or VBA. Column P contains numerous rows ranging from 1-1500 in any given month. Each cell in column P contains a paragraph of information. Somewhere within each paragraph is a brief statement "x of x cores". i need to extract that statement from each cell. unfortunately "x of x cores" can be any combination of "zero of one core" or "two of four cores" or "four of four cores" or "zero of three cores" etc all the way up to four of four and the numbers are always spelled out.

any ideas how to make this happen?

Column P random paragraph	extracted result
;jlasijfaoij asolifdj ; ashdfa hfosdf ;oa ufoa two of two cores aosihfo ahsodfh sofah ashdf o	two of two cores
klaslfjas sldkjf asjd asljfoij fofheoiwehf J;OASDHF OW j;asld % aofh # of % one of three oiaskdn aoshf a oiasofi	one of three cores
oiafj;as oasfan aofa oai foajf oaiaf two of four cores aosifal oais f oai f oaif oj;oiashodfu %	two of four

 

[RattlingCarp3048]

You needed to Insert a Module and place it there.

ah, i see what i did wrong. i didnt know about the function, ive only ever used subs so when it prompted me for a name i didnt question it. i inserted a new module and added the code. it did not prompt me for a sub name this time. my data starts in P2 and the next free column is T. all i got was a #value error. i also tried the other suggestion to use scores with the s in brackets but that gave me the same error.

 

[RattlingCarp3048]

I've amended my code a bit because InStr can be replaced with matches:

Sub RattlingCarp3048_5()
Dim i As Long, j As Long, k As Long
Dim tx As String
Dim va, vx, ary, vb
Dim regEx As Object, Matches As Object

    ary = Split("zero one two three four")
    ReDim vx(1 To 30, 1 To 1)
    For i = 0 To UBound(ary)
        For j = i To UBound(ary)
            k = k + 1
            vx(k, 1) = ary(i) & " of " & ary(j) & " core"
            k = k + 1
            vx(k, 1) = ary(i) & " out of " & ary(j) & " core"
        Next
    Next
   
    va = Range("A1", Cells(Rows.Count, "A").End(xlUp))
    ReDim vb(1 To UBound(va, 1), 1 To 1)
   
        Set regEx = CreateObject("VBScript.RegExp")
        With regEx
        For i = 1 To UBound(va, 1)
            tx = LCase(va(i, 1))
            For Each x In vx
                .Pattern = "\b" & x & "[s]{0,1}\b"
                If .test(tx) Then
                       Set Matches = .Execute(tx)
                       vb(i, 1) = vb(i, 1) & ", " & Matches(0)
                End If
            Next
            If vb(i, 1) <> "" Then vb(i, 1) = Mid(vb(i, 1), 3, 50000)
        Next
        End With
Range("B1").Resize(UBound(vb, 1), 1) = vb
End Sub

@Akuini any idea why these were rejected? this is a small snippit but it looks like quite a few similar to this were rejects but i cannot make out why.

AND 75% OF TWO OF TWO CORES, 3 MM AND 6 MM

AND 93% OF TWO OF TWO CORES, 9.5 MM AND 13 MM

20%, ONE OF TWO CORES, 4 MM

6% OF ONE OF TWO CORES, 0.5 MM

AND 83% OF TWO OF TWO CORES, 4 MM AND 5 MM

AND 94% OF TWO OF TWO CORES, 8 MM AND 7.5 MM, RESPECTIVELY

30%, ONE OF TWO CORES, 5 MM

 

[Akuini]

@Akuini any idea why these were rejected? this is a small snippit but it looks like quite a few similar to this were rejects but i cannot make out why.

It works on my side, can you test it again?

RattlingCarp3048 - regex.xlsm
	A	B
1
2	AND 75% OF TWO OF TWO CORES, 3 MM AND 6 MM	two of two cores
3	AND 93% OF TWO OF TWO CORES, 9.5 MM AND 13 MM	two of two cores
4	20%, ONE OF TWO CORES, 4 MM	one of two cores
5	6% OF ONE OF TWO CORES, 0.5 MM	one of two cores
6	AND 83% OF TWO OF TWO CORES, 4 MM AND 5 MM	two of two cores
7	AND 94% OF TWO OF TWO CORES, 8 MM AND 7.5 MM, RESPECTIVELY	two of two cores
8	30%, ONE OF TWO CORES, 5 MM	one of two cores
Sheet3

and I amended the code a bit to make it faster by adding "If InStr(tx, "core") Then". So, use this one instead:

Sub RattlingCarp3048_6()

Dim i As Long, j As Long, k As Long
Dim tx As String
Dim va, vx, ary, vb
Dim regEx As Object, Matches As Object

    ary = Split("zero one two three four")
    ReDim vx(1 To 30, 1 To 1)
    For i = 0 To UBound(ary)
        For j = i To UBound(ary)
            k = k + 1
            vx(k, 1) = ary(i) & " of " & ary(j) & " core"
            k = k + 1
            vx(k, 1) = ary(i) & " out of " & ary(j) & " core"
        Next
    Next
  
    va = Range("A1", Cells(Rows.Count, "A").End(xlUp))
    ReDim vb(1 To UBound(va, 1), 1 To 1)
  
        Set regEx = CreateObject("VBScript.RegExp")
        With regEx
        For i = 1 To UBound(va, 1)
            tx = LCase(va(i, 1))
            If InStr(tx, "core") Then
                For Each x In vx
                    .Pattern = "\b" & x & "[s]{0,1}\b"
                    If .test(tx) Then
                           Set Matches = .Execute(tx)
                           vb(i, 1) = vb(i, 1) & ", " & Matches(0)
                    End If
                Next
                If vb(i, 1) <> "" Then vb(i, 1) = Mid(vb(i, 1), 3, 50000)
            End If
        Next
        End With
Range("B1").Resize(UBound(vb, 1), 1) = vb
End Sub

 

[RattlingCarp3048]

It works on my side, can you test it again?

RattlingCarp3048 - regex.xlsm
	A	B
1
2	AND 75% OF TWO OF TWO CORES, 3 MM AND 6 MM	two of two cores
3	AND 93% OF TWO OF TWO CORES, 9.5 MM AND 13 MM	two of two cores
4	20%, ONE OF TWO CORES, 4 MM	one of two cores
5	6% OF ONE OF TWO CORES, 0.5 MM	one of two cores
6	AND 83% OF TWO OF TWO CORES, 4 MM AND 5 MM	two of two cores
7	AND 94% OF TWO OF TWO CORES, 8 MM AND 7.5 MM, RESPECTIVELY	two of two cores
8	30%, ONE OF TWO CORES, 5 MM	one of two cores
Sheet3

and I amended the code a bit to make it faster by adding "If InStr(tx, "core") Then". So, use this one instead:

Sub RattlingCarp3048_6()

Dim i As Long, j As Long, k As Long
Dim tx As String
Dim va, vx, ary, vb
Dim regEx As Object, Matches As Object

    ary = Split("zero one two three four")
    ReDim vx(1 To 30, 1 To 1)
    For i = 0 To UBound(ary)
        For j = i To UBound(ary)
            k = k + 1
            vx(k, 1) = ary(i) & " of " & ary(j) & " core"
            k = k + 1
            vx(k, 1) = ary(i) & " out of " & ary(j) & " core"
        Next
    Next
 
    va = Range("A1", Cells(Rows.Count, "A").End(xlUp))
    ReDim vb(1 To UBound(va, 1), 1 To 1)
 
        Set regEx = CreateObject("VBScript.RegExp")
        With regEx
        For i = 1 To UBound(va, 1)
            tx = LCase(va(i, 1))
            If InStr(tx, "core") Then
                For Each x In vx
                    .Pattern = "\b" & x & "[s]{0,1}\b"
                    If .test(tx) Then
                           Set Matches = .Execute(tx)
                           vb(i, 1) = vb(i, 1) & ", " & Matches(0)
                    End If
                Next
                If vb(i, 1) <> "" Then vb(i, 1) = Mid(vb(i, 1), 3, 50000)
            End If
        Next
        End With
Range("B1").Resize(UBound(vb, 1), 1) = vb
End Sub

I did some more digging and a deeper comparison on the ones it keeps rejecting and figured it out. We have some major clean up on our end to do for better standardization but otherwise this seems to be working perfectly . i never did hear back about the other code suggestion so im marking yours as the solution thank you for all your help. I really appreciate your time and efforts!

 

[Akuini]

You're welcome, glad to help & thanks for the feedback.