Excel VBA Code to Combine (concat) cells with If Statement and/or ContainWord - vba

Question

I am attempting to add VBA code which will combine cells which would be more complete together. For example, each cell which contains the word "Class" is good on its own. However, if a cell contains "Classes", it should also contain "and". Some of the cells which contain "Classes" do not contain "and". That cell which contains the associated "and" is one or two lines down below, but it is the next cell.
Classes GE, GH, GK, GL, GN, GP,
GQ and IG
Class LD
Class LP
Classes H, HB, HC, HD, HE, HG,
HI, HJ, HK, HL, HN, HP and HQ
Classes E, EA, EB, EC, ED, EG and EI
The line with "Classes E, EA, EB, EC, ED, EG and EI" is good on its own as the "Classes" and "and" are in the same cell. The cell containing "Classes GE..." and the cell below it, "GQ and IG" need to now become one cell.
The code I have so far is:
Dim cell As Range
Dim ContainWord, ContainWord2, ContainWord3, ContainWord4 As String
Dim lngTotRows As Integer
lngTotRows = Range("A" & Rows.Count).End(xlUp).Row
Set rng = Range("A1:BB" & lngTotRows)
ContainWord = "Class"
ContainWord2 = "Classes"
ContainWord3 = "and"
ContainWord4 = ","
'Delete all cells without the ContainWords
For Each cell In rng.Cells
If cell.Find(ContainWord) Is Nothing And cell.Find(ContainWord2) Is Nothing
And cell.Find(ContainWord3) Is Nothing And cell.Find(ContainWord4) Is
Nothing Then cell.Clear
Next cell
Range("A1").Select
'Combine cells which have "classes" but not "and" with the subsequent cells
which contain "and"
For Each cell In rng.Cells
If InStr(cell, ContainWord2) > 0 And InStr(cell, ContainWord3) = 0 Then
My first task of deleting everything which did not contain those contain words works great. It's the next part I am having difficulty with. I have looked over a bunch of other threads regarding ifs and containwords and combine and InStr, but haven't been able to figure out what to do after the "Then". Any help would be much appreciated.

Answer 1

I saw a different logic in your data and therefore took a different approach: If the word "class" isn't in a cell's content then it must be appended to the previous. I also don't recommend to delete data (they took so much time to accumulate, lol:). Instead, my code below writes a new list. I placed this list on the same sheet but you could create it anywhere.
Before you try the code please set a suitable TargetColumn at the top of the code. I also recommend that you replace With Activesheet with something like With Worksheets("My List of Classes") which would make the code less accident prone.
Private Sub MergeClassList()
' 08 Jan 2018
Const TargetColumn As Long = 10 ' column to write result to
Dim Itm As String, Out As String
Dim Sp() As String ' helper to insert "and"
Dim Rt As Long ' Target row
Dim Rl As Long ' last used row
Dim R As Long
Application.ScreenUpdating = False
With ActiveSheet
Rl = .Cells(.Rows.Count, "A").End(xlUp).Row
Rt = 2 ' start output in row 2
For R = 2 To Rl ' first data row = 2
Itm = Trim(.Cells(R, "A").Value)
If InStr(1, Itm, "class", vbTextCompare) = 1 Then
If Len(Out) Then
.Cells(Rt, TargetColumn).Value = Out
Rt = Rt + 1
End If
Out = Itm
Else
If Len(Out) Then
If Right(Out, 1) <> "," Then Out = Out & ","
Out = Replace(Out, " and", ",") & " "
End If
Out = Out & Itm
If InStr(Out, ",") And (InStr(1, Out, "and", vbTextCompare) = 0) Then
Sp = Split(Out, ",")
Do
Out = Left(Out, Len(Out) - 1)
Loop Until Right(Out, 1) = ","
Out = Left(Out, Len(Out) - 1) & " and" & Sp(UBound(Sp))
End If
End If
Next R
If Len(Out) Then .Cells(Rt, TargetColumn).Value = Out
End With
Application.ScreenUpdating = True
End Sub

Answer 2

Concatenate in vba can be substituted with "&" and strings
dim string1,string2 as string
dim nextCell as range
For Each cell In rng.Cells
string1= cell.text
if instr(string1, containword2) >0 and not instr(string1, containword3) >0 then
set nextcell = activeworksheet.usedrange.find(what:=containword3, after:=cell.address, _
lookat:=xlpart, lookinxlformulas, _
search order:= xlbyrows, searchdirection:=xlnext, _
matchcase:=false)
string2= nextcell.text
cell.text= string1 & " " & string2
nextcell.clear
end if
Next cell
code is untested, the idea is find the next cell that contains the word "and" and concatenate it with current cell. However, there is a case where next cell could contain both "Classes" and "and", which the above code would not work on. Not sure if you have this case in your data. Let me know if you do.