Conditional cell text formatting

[jimwales]

Hi everyone,

I was just introduced to this forum and have read a lot of wonderful solutions regarding my VBA issues.
I'm stuck on this particular problem and can't seem to make it work in excel. I'm a borderline n00b so please bare with me.

I managed to find this vba script from somewhere else, however I didn't write it. When it runs, it adds a 'TEXT' to the end of every line in every cell of a given column.

Sub AddText()    
    Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
    Dim myCell As Variant, myRange As Range, myArray() As String
    Dim i As Integer


    Set myRange = ws.Range("A1", ws.Cells(ws.Rows.Count, "A").End(xlUp))


    For Each myCell In myRange
        myArray= Split(myCell, Chr(10))
        myCell.Value = ""
        For i = 0 To UBound(myArray)
            myArray(i) = myArray(i) & " TEXT"
            If i = UBound(myArray) Then
                myCell.Value = myCell.Value & myArray(i)
            Else: myCell.Value = myCell.Value & myArray(i) & Chr(10)
            End If
        Next i
    Next myCell
End Sub

This script works fine and does the job. However what I need to achieve is for there to be an if statement saying that: out of all the lines that the 'TEXT' is being added to, if any line has less than say 5 words OR ends with a colon, add a 'TEXT TEXT' instead of just 'TEXT' to the end of that line. So if a cell contains:

One two three four five six seven eight nine ten
One two three four five six seven eight:
One two three four five six
One two

It should be edited to have this text:

One two three four five six seven eight nine ten TEXT
One two three four five six seven eight: TEXT TEXT
One two three four five six TEXT
One two TEXT TEXT

So basically put, if a line in a cell meets either of the two conditions (less than 5 words or ends in a colon), "TEXT TEXT" is concatenated to the end of the line. If the line meets none of those two conditions, "TEXT" is concatenated to the end, which is what the script above already does.

So far, I've tried adding If statements within that code saying

 If myCell.len < 5 Then

 If myCell.value < 5 Then

and have tried tweaking the syntax but I usually keep getting syntax and compiling errors which was very frustrating and demotivating since I couldn't get anywhere.


Any sort of help is really appreciated!
Thank you

 

[Marcelo Branco]

Welcome to Mr Excel

Maybe this...

Sub AddText()
    Dim ws As Worksheet
    Dim myCell As Variant, myRange As Range, myArray() As String
    Dim i As Integer
    Dim strAddText As String

    Set ws = ThisWorkbook.Sheets(1)
    Set myRange = ws.Range("A1", ws.Cells(ws.Rows.Count, "A").End(xlUp))

    For Each myCell In myRange
        myArray = Split(myCell, Chr(10))
        myCell.Value = ""
        For i = 0 To UBound(myArray)
            'Check if less than 5 words or last character is a colon
            If UBound(Split(myArray(i))) < 4 Or Right(myArray(i), 1) = ":" Then
                strAddText = " TEXT TEXT"
            Else
                strAddText = " TEXT"
            End If
            
            myArray(i) = myArray(i) & strAddText
            If i = UBound(myArray) Then
                myCell.Value = myCell.Value & myArray(i)
            Else
                myCell.Value = myCell.Value & myArray(i) & Chr(10)
            End If
        Next i
    Next myCell
End Sub

Hope this helps

M.

 

[Marcelo Branco]

Or this
More robust (deals with extraneous spaces); see code line in red

Sub AddText()
    Dim ws As Worksheet
    Dim myCell As Variant, myRange As Range, myArray() As String
    Dim i As Integer
    Dim strAddText As String

    Set ws = ThisWorkbook.Sheets(1)
    Set myRange = ws.Range("A1", ws.Cells(ws.Rows.Count, "A").End(xlUp))

    For Each myCell In myRange
        myArray = Split(myCell, Chr(10))
        myCell.Value = ""
        For i = 0 To UBound(myArray)
            [COLOR=#ff0000]myArray(i) = Application.Trim(myArray(i))[/COLOR]
            'Check if less than 5 words or last character is a colon
            If UBound(Split(myArray(i))) < 4 Or Right(myArray(i), 1) = ":" Then
                strAddText = " TEXT TEXT"
            Else
                strAddText = " TEXT"
            End If
            
            myArray(i) = myArray(i) & strAddText
            If i = UBound(myArray) Then
                myCell.Value = myCell.Value & myArray(i)
            Else
                myCell.Value = myCell.Value & myArray(i) & Chr(10)
            End If
        Next i
    Next myCell
    ws.Columns(1).AutoFit
End Sub

M.

 

[jimwales]

Marcelo,

Your code works flawlessly. I'm going to study up how it's done as I was stuck on this for ages.

Thank you very much,
JW

 

[Marcelo Branco]

You are welcome. Glad to help.

M.

 

[jimwales]

Sorry to bring you back. I was wondering, I tried the code and I have a small issue but it's from my part. Some of my cells have line breaks before and after the main chunk of actual text. Is there a way to remove those? I tried some codes with trim() and clean(), but instead it consolidated all lines of the cells into one line. So basically to go from this:

[EMPTY BREAK]
[EMPTY BREAK]
one two three
[EMPTY BREAK]
one two three
[EMPTY BREAK]
one two three
[EMPTY BREAK]
[EMPTY BREAK]

to:

one two three
[EMPTY BREAK]
one two three
[EMPTY BREAK]
one two three

so that the "TEXT" that we coded to be added won't add to the empty breaks in the beginning and end of the chunk of text.

JW

 

[Marcelo Branco]

hmm...not sure i understand what you mean [EMPTY BREAK]
What is the character?
Have you tried SUBSTITUTE?

M.

 

[Marcelo Branco]

See if this removes the extras Chr(10) at the beginning and end
(try it on a copy of your workbook)

Copy/Paste the sub and two functions
Select the cells and run the sub

Sub ArrangeString()
    Dim rCell As Range, PosFirst As String, PosLast As String
    For Each rCell In Selection
        PosFirst = FirstLetter(rCell.Value)
        PosLast = LastLetter(rCell.Value)
        rCell = Mid(rCell.Value, PosFirst, PosLast - PosFirst + 1)
    Next rCell
End Sub
Public Function FirstLetter(s1 As String) As Long
    Dim i As Long
    For i = 1 To Len(s1)
        If Mid(s1, i, 1) Like "[a-zA-Z]" Then
            FirstLetter = i
            Exit Function
        End If
    Next i
End Function
Public Function LastLetter(s1 As String) As Long
    Dim i As Long
    For i = 1 To Len(s1)
        If Mid(s1, i, 1) Like "[a-zA-Z]" Then
            LastLetter = i
        End If
    Next i
End Function

M.

 

[jimwales]

Hi Marcelo,

I haven't had access to the internet lately, apologies. The code works great, however it gives an error with empty cells. But I think I should try and fix that myself.

Thank you again for all your help.
JW

 

[Marcelo Branco]

You are welcome. Thanks for the feedback.

M.