Excel Macro multiple range concatenation

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.