Excel Macro множественная конкатенация диапазона

Question

Я пытаюсь объединить ячейки через excel VBA. Это связано с несколькими диапазонами. Ниже мой стол

Degree1
Course1, Course2, Course3
Course4, course5, course6

степени 2
Course1, Course2
Course3, Course4
Course5
Course6, Course7

Степень 3
Курс1, курс2, курс3
Course4, course5, course6
Course7

Я хочу, чтобы объединить все курсы, перечисленные ниже степени в одну ячейку рядом степени. Каждая степень имеет несколько курсов & количество строк различается для каждой степени.

Я использую функцию поиска excel для идентификации ячейки, содержащую степень &, выберите курсы под ней. Я также использую функцию concat от http://www.contextures.com/rickrothsteinexcelvbatext.html, чтобы я мог конкатенировать выбранные диапазоны.

Я попытался написать приведенный ниже код, но это не работает, я получаю ошибку значения в конце. Я предполагаю, что диапазон не хранится в переменной

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 

Я повторив этот процесс конкатенации для других степеней.

Answer 1

Команда VBA .Join должна хорошо работать здесь.

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 

я составила для случая, когда существует только один (или нет) линии градусов ниже названия DegreesX. Код зависит от каждого «заголовка», начиная с Степень в качестве первых 6 символов (не чувствителен к регистру). Я использовал .Offset(x, y), где просто +1 до строки или столбца, вероятно, было бы достаточно, но это может помочь в понимании цели различных строк кода.