Kopier samme celle fra alle ark til en oversigt

Sub opbygIndex()
Const oversigtsArkNavn = "index"
Dim ark
Dim arkI, rækI
    Set arkI = ActiveWorkbook.Sheets(oversigtsArkNavn)
    rækI = 1

    Application.ScreenUpdating = False

    For Each ark In ActiveWorkbook.Sheets
        If LCase(ark.Name) <> oversigtsArkNavn Then
            ActiveWorkbook.Sheets(ark.Name).Activate
           
            With arkI
                .Cells(rækI, 1) = ark.Name
                .Cells(rækI, 2) = ActiveSheet.Range("B25")
                .Cells(rækI, 3) = ActiveSheet.Range("C25")
                .Cells(rækI, 4) = ActiveSheet.Range("D25")
                .Cells(rækI, 5) = ActiveSheet.Range("E25")
            End With
            rækI = rækI + 1
        End If
    Next
   
    Application.ScreenUpdating = True
    arkI.Activate
End Sub

PS: koden er anbragt "under" oversigtsarket

Hold kæft det er smart.
Læg et svar.

Og igen - mange tak.

Selv tak - jeg lægger et svar...