Прокручивать листы и копировать значения в диапазон

Question

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

Sub copyGrades()
    Dim ws As Excel.Worksheet
    Dim grade As Double

    Dim rng As Range
    Dim rcell As Range
    Set rng = ThisWorkbook.Worksheets("Student List").Range("H2:H174")

    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> "Rubric" And ws.Name <> "Student List" Then
            grade = ws.Range("E11").Value

            For Each rcell In rng.Cells
                rcell.Value = grade
            Next rcell

        End If
    Next ws
End Sub

Answer 1

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

Sub copyGrades()

    Dim ws As Excel.Worksheet
    Dim rng As Range
    Dim rcell As Range
    Set rng = ThisWorkbook.Worksheets("Student List").Range("F2:F174")

            For Each rcell In rng.Cells

                For Each ws In ActiveWorkbook.Worksheets
                    If ws.Name = rcell.Value Then
                        rcell.Offset(0, 3).Value = ws.Range("E11").Value
                    End If
                Next ws

            Next rcell
End Sub

Answer 2

Я думаю, вот как бы я это сделал (конечно, не единственный способ):

Option Explicit

Sub copyGrades()
    Dim ws As Excel.Worksheet
    Dim grade As Double
    Dim rng As Range
    Dim count As Integer

    count = 1
    Set rng = ThisWorkbook.Worksheets("Student List").Range("H2:H174")

    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> "Rubric" And ws.Name <> "Student List" Then
            grade = ws.Range("E11").Value
            rng.Cells(count, 1) = grade
            count = count + 1
        End If
    Next
End Sub