Examine each word of a cell and make a decision depending on its length

[makiwara]

Hi!

I need the code, which does the following:

"Examine each word of a cell and if the word's length is 6 Characters or less, then left(word, 1) else (if word's length is more then 6 characters) then left(word, 2)
Apple --> A (5)
Christi Jonathan --> Ch Jo (7 and 8)
Apple Training --> A Tr (5 and 8)


https://imgur.com/onQF3KI

I could solve it, I worked on it 3 hours. I am a beginner and it was a terrible experience. But I did it.
What sad is, that my code is 10 A4 page long. https://imgur.com/a/2RWncEF

I don't know whether its a good idea to ask for a profesionnal solution or not, but let's try. (My soul wil be broken if somebody solves it in 10 lines, which is very likely

Have a nice day!

 

[mumps]

Try:

Sub makiwara()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim rng As Range
    Dim vRng As Variant
    Dim i As Long
    For Each rng In Range("A1:A" & LastRow)
        vRng = Split(rng, " ")
        For i = LBound(vRng) To UBound(vRng)
            If Len(vRng(i)) <= 6 Then
                rng.Offset(0, 1) = Trim(rng.Offset(0, 1) & " " & Left(vRng(i), 1))
            Else
                rng.Offset(0, 1) = Trim(rng.Offset(0, 1) & " " & Left(vRng(i), 2))
            End If
        Next i
    Next rng
    Application.ScreenUpdating = True
End Sub

 

[Fluff]

Another option

Sub trimWords()
   Dim Wrd As Variant
   Dim Cl As Range
   
   For Each Cl In Range("A1", Range("A" & Rows.Count).End(xlUp))
      For Each Wrd In Split(Cl, " ")
         Cl.Offset(, 1).Value = Cl.Offset(, 1).Value & " " & IIf(Len(Wrd) <= 6, Left(Wrd, 1), Left(Wrd, 2))
      Next Wrd
   Next Cl
End Sub

 

[makiwara]

Thank you both!!! You are so professionnal! I hope one day I can become an expert like you :D

 

[mumps]

Glad we could help.

 

[makiwara]

Sorry for writing again! Between some words on my list there are "page breaks" instead of "spaces"
I think they are page breaks, because 2 words seem to belong together.

For example:
Never give up --> Instead of N g u --> N


Is it possible to add a row which changes every page break to space? I would try it, but your solution are too professional, so I am not brave enough to edit and modify it :D

Glad we could help.

 

[Fluff]

Try

Sub trimWords()
   Dim Wrd As Variant
   Dim Cl As Range
   Range("A:A").Replace Chr(10), " ", , , , , False, False
   For Each Cl In Range("A1", Range("A" & Rows.Count).End(xlUp))
      For Each Wrd In Split(Cl, " ")
         Cl.Offset(, 1).Value = Cl.Offset(, 1).Value & " " & IIf(Len(Wrd) <= 6, Left(Wrd, 1), Left(Wrd, 2))
      Next Wrd
   Next Cl
End Sub

 

[makiwara]

Thanks Fluff, works fine!
// I couldn't express myself properly: those were not page breaks, but non-breaking spaces if I name them right, so use Chr(160) if somebody needs it :D //

Have a nice day!

 

[Fluff]

Glad you got it sorted & thanks for the feedback