Excel Macro multiple range concatenation - vba

Question

I am trying to concatenate cells through excel VBA. This involves multiple ranges. Below is my table
Degree1
Course1,Course2,Course3
Course4,course5,course6
Degree2
Course1,Course2
Course3,Course4
Course5
Course6,Course7
Degree3
Course1,Course2,Course3
Course4,course5,course6
Course7
I want to concatenate all the courses listed below a degree into a single cell next to the degree. Each degree has multiple courses & the # of rows differ for each degree.
I am using excel find function to identify the cell contains the degree & select the courses below it. I am also using the concat function from http://www.contextures.com/rickrothsteinexcelvbatext.html so that I can concatenate the selected ranges.
I tried to write the below code but this is not working, I am getting value error in the end. I guess the range is not stored in the variable
Sub concatrange()
Dim D1Crng As Range 'to set courses under degree1 as range
Dim D2Crng As Range
Dim D3Crng As Range
Dim D1cell As Range 'to identify the cell of D1 and set it as range
Dim D2cell As Range
Dim D3cell As Range
Range("A1:B100").Select
Selection.Find(What:="Degree1", _
LookIn:=xlValues, LookAt:=xlPart, _
SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Select
ActiveCell.Select
Set D1cell = Selection
Range(D1cell).Activate
ActiveCell.Offset(1, 0).End(xlDown).Select
Set D1Crng = Selection
Range(D1cell).Activate
ActiveCell.Offset(0, 1).Select
Selection.Formula = "=concat("","",D1Crng)"
End sub
I am repeating the above process for concatenating for other degrees.

Answer 1

VBA's .Join command should work well here.
Sub many_degrees()
Dim rw As Long
With ActiveSheet
For rw = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
If LCase(Left(.Cells(rw, 1).Value, 6)) = "degree" Then
If Application.CountA(.Cells(rw, 1).Resize(3, 1)) > 2 Then
.Cells(rw, 2) = Join(Application.Transpose(.Range(.Cells(rw, 1).Offset(1, 0), .Cells(rw, 1).End(xlDown)).Value), Chr(44))
Else
.Cells(rw, 2) = .Cells(rw, 1).Offset(1, 0).Value
End If
End If
Next rw
End With
End Sub
I have accounted for the case where only one (or none) line of degrees exists below the DegreesX title. The code does depend upon each 'title' starting with Degree as the first 6 characters (not case sensitive). I've used .Offset(x, y) where a simple +1 to the row or column probably would have sufficed, but that may help in understanding the purpose of the various code lines.