VBA Script to Fill Cell into List Below and Repeat - vba

Question

I have a spreadsheet that list a Case Manager and then list the students below it. Then it lists another Case Manager and students below it. I want to copy the Case Manager Name from the top of each list to the end of the row of respective students underneath, repeating with each Case Manager until I get to the end of my sheet. The number of Case Managers and students can vary.
I have the following code to do the first Case Manager but not sure how to loop it of if there is a better solution. I want all the data to stay in the original spot.
Original Source: (Imported Text File)
Modified Source: (After Macro is Run)
Sub CMWizard()
Dim CMName As String
Dim StopRow As Long
Dim r As Long
CMName = Range("A1").Value 'Get the Case Manager Name.
StopRow = Range("B2").End(xlDown).Row 'Get first blank cell in Column B.
For r = 2 To StopRow 'Start at Row 2 and continue until you reach the StopRow.
Cells(r, 6).Value = CMName 'Set every cell from Row 2 in Column F (6) to the Case Manager Name.
End Sub

Answer 1

Let's say your Excel file looks like this
Paste this code in a module. I have commented the code so that you will not have a problem understanding it.
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim i As Long, LRow As Long, R As Long
Dim CM As String
Dim delRng As Range
Application.ScreenUpdating = False
'~~> Replace Sheet 1 with the relevant sheet name
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Get last row of Col A
LRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Loop through cells in Col A
For i = 1 To LRow
'~~> Check if the cell contains "Case Manager"
If InStr(1, .Cells(i, 1).Value, "Case Manager", vbTextCompare) Then
'~~> Store the Case manager's name in a variable
CM = .Cells(i, 1).Value
'~~> Store the row numbers which have "Case Manager"
'~~> We will delete it later
If delRng Is Nothing Then
Set delRng = .Rows(i)
Else
Set delRng = Union(delRng, .Rows(i))
End If
Else
'~~> Store the Case manager in Col F
.Cells(i, 6).Value = CM
End If
Next i
End With
'~~> Delete the rows which have "Case Manager"
If Not delRng Is Nothing Then delRng.Delete
Application.ScreenUpdating = True
End Sub
Output

Answer 2

i think you are just missing an next
Sub CMWizard()
Dim CMName As String
Dim StopRow As Long
Dim r As Long
CMName = Range("A1").Value 'Get the Case Manager Name.
StopRow = Range("B2").End(xlDown).Row 'Get first blank cell in Column B.
For r = 2 To StopRow 'Start at Row 2 and continue until you reach the StopRow.
Cells(r, 6).Value = CMName 'Set every cell from Row 2 in Column F (6) to the Case Manager Name.
Next
End Sub
just be aware that StopRow = Range("B2").End(xlDown).Row will return last row in worksheet if there are just empty cells below ("B2")
Hope it helps