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

Question

我有一个列出案例管理器的电子表格，然后列出它下面的学生。然后它列出了另一个案例管理员和它下面的学生。我想将每个列表顶部的案例管理器名称复制到下面各个学生行的末尾，重复每个案例管理器，直到我到达表格的末尾。案例管理员和学生的数量可能会有所不同。

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

原始来源:(导入的文本文件）

修改源:(运行宏后）

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

我认为你错过了下一个

    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

请注意，如果下面只有空单元格，那么StopRow = Range("B2").End(xlDown).Row将返回工作表的最后一行（＆＃34; B2＆＃34;）

希望有所帮助

Answer 2

假设您的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        

<强>输出