Split first word only if it is part of a range.

[topi1]

In the following example, I have a range of values in the column E. data in the column A. In the columns B and C I have entered formulas (arrived by working stepwise on several columns and then combining it). Everything works well and extracts first word from A into column B only if it is part of the range in the column E. And it leaves the rest in the column C.
Is it possible to have a vba which can do the same thing? Thank you.

rscripto11.xlsm
	A	B	C	D	E
42	GM #1		GM #1		One
43	Dodge #4		Dodge #4		Two
44	Ford #2		Ford #2		Three
45	Jeep #3		Jeep #3		Four
46	One Dodge	One	Dodge		Five
47	Two Dodge	Two	Dodge
48	Two Jeep	Two	Jeep
49	One Dodge	One	Dodge
50	One Jeep	One	Jeep
51	Two Jeep	Two	Jeep
Sheet6

Cell Formulas
Range	Formula
B42:B51	B42	=IF((COUNTIF($E$42:$E$51,IFERROR(LEFT(A42, FIND(" ", A42)-1), A42))=1),IFERROR(LEFT(A42, FIND(" ", A42)-1), A42),"")
C42:C51	C42	=IF((COUNTIF($E$42:$E$51,IFERROR(LEFT(A42, FIND(" ", A42)-1), A42))=1),IF((ISERROR(SUBSTITUTE(A42,LEFT(A42,FIND(" ",A42)),""))=FALSE),SUBSTITUTE(A42,LEFT(A42,FIND(" ",A42)),""),""),A42)

 

[mumps]

Try:

Sub SplitFirstWord()
    Application.ScreenUpdating = False
    Dim fnd As Range, v As Variant, i As Long
    v = Range("A42", Range("A" & Rows.Count).End(xlUp)).Resize(, 2).Value
    For i = LBound(v) To UBound(v)
        Set fnd = Range("E42:E46").Find(Split(v(i, 1), " ")(0))
        If Not fnd Is Nothing Then
            Range("B" & i + 41) = Split(v(i, 1), " ")(0)
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

 

[topi1]

Try:

Sub SplitFirstWord()
    Application.ScreenUpdating = False
    Dim fnd As Range, v As Variant, i As Long
    v = Range("A42", Range("A" & Rows.Count).End(xlUp)).Resize(, 2).Value
    For i = LBound(v) To UBound(v)
        Set fnd = Range("E42:E46").Find(Split(v(i, 1), " ")(0))
        If Not fnd Is Nothing Then
            Range("B" & i + 41) = Split(v(i, 1), " ")(0)
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

@mumps Thank you for your prompt help. Can you please help me with two issues?
1) It did not extract the rest. Column C remains empty.
2) recognize numbers as first word in case in the column E it has a cell that has 7 instead of seven. The current vba does not recognize 7. I don't know how to use excel formula TEXT for vba.
Thank you.

 

[kvsrinivasamurthy]

Code.> Adjust the ranges as required.

Sub GetFirstword()
Dim A, R, M, ary, Lr&, T&, Ta&
Lr = Range("A" & Rows.Count).End(xlUp).Row
A = Range("A3:A" & Lr)
ReDim R(1 To UBound(A, 1), 1 To 1)
ary = Range("E3:E7")

With CreateObject("scripting.dictionary")
For T = 1 To UBound(ary, 1)
.Add ary(T, 1), T
Next T

For Ta = 1 To UBound(A, 1)
M = Split(A(Ta, 1), " ")
If .exists(M(0)) Then R(Ta, 1) = M(0)
Next Ta
End With

Range("B3:B" & Lr) = R
End Sub

 

[topi1]

Code.> Adjust the ranges as required.

Sub GetFirstword()
Dim A, R, M, ary, Lr&, T&, Ta&
Lr = Range("A" & Rows.Count).End(xlUp).Row
A = Range("A3:A" & Lr)
ReDim R(1 To UBound(A, 1), 1 To 1)
ary = Range("E3:E7")

With CreateObject("scripting.dictionary")
For T = 1 To UBound(ary, 1)
.Add ary(T, 1), T
Next T

For Ta = 1 To UBound(A, 1)
M = Split(A(Ta, 1), " ")
If .exists(M(0)) Then R(Ta, 1) = M(0)
Next Ta
End With

Range("B3:B" & Lr) = R
End Sub

@kvsrinivasamurthy I got an error in the following line.
.Add ary(T, 1), T

 

[mumps]

Try:

Sub SplitFirstWord()
    Application.ScreenUpdating = False
    Dim fnd As Range, v As Variant, i As Long
    v = Range("A42", Range("A" & Rows.Count).End(xlUp)).Resize(, 2).Value
    For i = LBound(v) To UBound(v)
        Set fnd = Range("E42:E46").Find(Split(v(i, 1), " ")(0))
        If fnd Is Nothing Then
            Range("C" & i + 41) = v(i, 1)
        Else
            Range("B" & i + 41) = Split(v(i, 1), " ")(0)
            Range("C" & i + 41) = Split(v(i, 1), " ")(1)
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

 

[kvsrinivasamurthy]

Try.

Sub Macro1()
Dim A, R, M, ary, Lr&, T&, Ta&
Lr = Range("A" & Rows.Count).End(xlUp).Row
A = Range("A3:A" & Lr)
ReDim R(1 To UBound(A, 1), 1 To 1)
ary = Range("E3:E7")

With CreateObject("scripting.dictionary")
For T = 1 To UBound(ary, 1)
If ary(T, 1) <> "" Then .Add ary(T, 1), T
Next T

For Ta = 1 To UBound(A, 1)
If A(Ta, 1) <> "" Then
M = Split(A(Ta, 1), " ")
If .exists(M(0)) Then R(Ta, 1) = M(0)
End If
Next Ta
End With

Range("B3:B" & Lr) = R
End Sub

 

[JEC]

Sub jec()
 Dim ar, ar2, j As Long, jj As Long
 ar = Range("A42", Range("A" & Rows.Count).End(xlUp)).Resize(, 3)
 ar2 = Range("E42:E46")
 For j = 1 To UBound(ar)
   ar(j, 3) = ar(j, 1)
   For jj = 1 To UBound(ar2)
     If InStr(ar(j, 1), ar2(jj, 1)) Then
       ar(j, 2) = Split(ar(j, 1))(0)
       ar(j, 3) = Split(ar(j, 1))(1)
       Exit For
     End If
   Next
 Next
 Range("A42", Range("A" & Rows.Count).End(xlUp)).Resize(, 3) = ar
End Sub

 

[topi1]

Try.

Sub Macro1()
Dim A, R, M, ary, Lr&, T&, Ta&
Lr = Range("A" & Rows.Count).End(xlUp).Row
A = Range("A3:A" & Lr)
ReDim R(1 To UBound(A, 1), 1 To 1)
ary = Range("E3:E7")

With CreateObject("scripting.dictionary")
For T = 1 To UBound(ary, 1)
If ary(T, 1) <> "" Then .Add ary(T, 1), T
Next T

For Ta = 1 To UBound(A, 1)
If A(Ta, 1) <> "" Then
M = Split(A(Ta, 1), " ")
If .exists(M(0)) Then R(Ta, 1) = M(0)
End If
Next Ta
End With

Range("B3:B" & Lr) = R
End Sub

Sorry. It did not work. Didn't give an error message but didn't do anything to columns B or C.

 

[topi1]

Try:

Sub SplitFirstWord()
    Application.ScreenUpdating = False
    Dim fnd As Range, v As Variant, i As Long
    v = Range("A42", Range("A" & Rows.Count).End(xlUp)).Resize(, 2).Value
    For i = LBound(v) To UBound(v)
        Set fnd = Range("E42:E46").Find(Split(v(i, 1), " ")(0))
        If fnd Is Nothing Then
            Range("C" & i + 41) = v(i, 1)
        Else
            Range("B" & i + 41) = Split(v(i, 1), " ")(0)
            Range("C" & i + 41) = Split(v(i, 1), " ")(1)
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

@mumps It works great as long the value in E is not a number. Is there a solution? I tried to add some columns and tried to use TEXT formula, but it did not work. TY.