VBA脚本将单元格填充到下面的列表中并重复

我有一个电子表格，列出一个案例经理，然后在下面列出学生。然后在下面列出另一个案例经理和学生。我想将案例经理的姓名从每个列表的顶部复制到下面相应学生行的末尾，与每个案例经理重复，直到我的工作表结束。案例经理和学生的数量可能会有所不同

我有以下代码来执行第一个案例管理器，但不确定如果有更好的解决方案，如何循环它。我希望所有数据都保留在原始位置

原始来源：导入的文本文件

修改的源：在运行宏之后

---

我想你只是错过了下一个机会

    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 

端接头

请注意，如果B2下方只有空单元格，StopRow=RangeB2.EndxlDown.Row将返回工作表中的最后一行

---

希望对您有所帮助

假设您的Excel文件如下所示

将此代码粘贴到模块中。我已经对代码进行了注释，这样您在理解代码时就不会有问题

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        

输出

---

不它仍然只填充第一组，即使下一组已经准备好了。我怎样才能让它在每一组学生中循环，并使用每个列表顶部的单元格作为我要填充的案例经理的名称？我想我很困惑。你能举个例子吗？另外，为了找到最后一行，您可能想使用为什么不添加输入和输出的屏幕截图？我不能确定数据是保密的。。。如果上面的解释仍然让人困惑，我可以创建一个模型。是的，一个模型会很好，因为我会问你更少的问题：P刚刚回答了你的问题。

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