Delete words under 3 leters

[Floopindoop]

I have a macro that splits a paragraph in A1 and puts each seprate word under the B collumn. I need a macro that can delete every cell with a word under 3 letters. It would also be good if it deleted 'the' and 'and'

 

[Jonmo1]

Welcome to the board...

Can you post the code you have, I should be fairly simple to ammend it to include this criteria.

 

[Scott Huish]

Sub test()
Dim d As Long, c As Range
For d = Range("B" & Rows.Count).End(xlUp).Row To 1 Step -1
    Set c = Range("B" & d)
    If Len(c) < 3 Or LCase(c) = "the" Or LCase(c) = "and" Then c.Delete xlShiftUp
Next
End Sub

 

[Floopindoop]

Here's the code i have right now



Sub SplitByWord()
Dim avs As Variant
Dim sAdr As String
Dim sFrm As String

With ActiveCell
avs = Split(.Value, " ")
If UBound(avs) > 0 Then
With .Offset(0, 1).Resize(UBound(avs) + 1)
.Value = Application.Transpose(avs)
sAdr = .Address
sFrm = "if(right(" & sAdr & ", 1) <> "" "", " & sAdr & " & "" "", " & sAdr & ")"
'Debug.Print sFrm
.Value = Evaluate(sFrm)
End With
End If
End With
End Sub

 

[Jonmo1]

incorporating the method posted by Hotpepper

Sub SplitByWord()
Dim avs As Variant
Dim sAdr As String
Dim sFrm As String
Dim i As Long
With ActiveCell
    avs = Split(.Value, " ")
    If UBound(avs) > 0 Then
        With .Offset(0, 1).Resize(UBound(avs) + 1)
            .Value = Application.Transpose(avs)
            For i = .Rows.Count To 1 Step -1
                If Len(.Cells(i, 1)) < 3 _
                Or LCase(.Cells(i, 1)) = "and" _
                Or LCase(.Cells(i, 1)) = "the" _
                Then .Cells(i, 1).Delete shift:=xlUp
            Next i
            sAdr = .Address
            sFrm = "if(right(" & sAdr & ", 1) <> "" "", " & sAdr & " & "" "", " & sAdr & ")"
            'Debug.Print sFrm
            .Value = Evaluate(sFrm)
        End With
    End If
End With
End Sub

 

[shg]

Re: Delete words under 3 letters

Try this:

Sub SplitByWord()
    Dim avs         As Variant
    Dim iR          As Long
    Dim iW          As Long
 
    With ActiveCell
        avs = Split(.Value, " ")
        iW = -1
 
        For iR = 0 To UBound(avs)
            If Len(avs(iR)) > 2 And _
               LCase(avs(iR)) <> "and" And _
               LCase(avs(iR)) <> "the" Then
                iW = iW + 1
                avs(iW) = avs(iR) & " "
            End If
        Next iR
 
        If iW <> -1 Then
            ReDim Preserve avs(0 To iW)
            If iW > 0 Then
                .Offset(, 1).Resize(iW + 1).Value = Application.Transpose(avs)
            End If
        End If
    End With
End Sub

 

[Floopindoop]

WOW thanks!

 

[Scott Huish]

or possibly:

Sub test()
Dim avs, t As Long, s As String, b As Long
avs = Split(Range("A1"))
For t = LBound(avs) To UBound(avs)
    s = LCase(avs(t))
    If Len(s) > 2 And s <> "the" And s <> "and" Then
        b = b + 1
        Range("B" & b) = s
    End If
Next
End Sub