Fout in code bij range voor for each cell

[eyeye]

Hallo,

Ik krijg een foutmedling bij mijn code en ik kan niet achterhalen waaraan dit ligt.

Het gaat om een for each cell constructie die het tabblad "planning" doorloopt en verschillende ranges kopiert naar een tabblad.
De eesrte keer in de loop gaat goed, echter de tweede keer blijft hij hangen en geeft hij aan dat de fout bij het te selecteren van de range zit. Ik weet niet waar dit aan ligt. kunnen jullie me helpen?

Sub archieveren()

Dim week As String
Dim shnaam As String
Dim Rng As Range


week = InputBox("Welke week moet gearchiveerd worden?", "Vul een getal in.")
Set workrange = ThisWorkbook.Sheets("planning").Range("A:A")

ThisWorkbook.Sheets("planning").Activate


    For Each cell In workrange
        If cell.Value = week Then
                cell.Range(Cells(1, 1), Cells(10, 8)).Select
                Selection.Copy
                shnaam = cell.Range("a2")
                        If Trim(week) <> "" Then
                             With Sheets(shnaam).Range("A:A")
                                Set Rng = .Find(What:=week, _
                                After:=.Cells(.Cells.Count), _
                                LookIn:=xlValues, _
                                LookAt:=xlWhole, _
                                SearchOrder:=xlByRows, _
                                SearchDirection:=xlNext, _
                                MatchCase:=False)
                                    If Not Rng Is Nothing Then
                                        Application.GoTo Rng, True
                                        ActiveCell.PasteSpecial
                                    Else
                                        MsgBox "Nothing found"
                                    End If
                            End With
                        End If
        End If
    Next cell
End Sub

Met vriendelijke groet,
Ronald.

 

[Niels28]

Zoiets?

Sub archieveren()

    Dim week As String
    Dim shnaam As String
    Dim Rng As Range

    week = InputBox("Welke week moet gearchiveerd worden?", "Vul een getal in.")
    If week <> "" Then
        For Each cl In ThisWorkbook.Sheets("planning").Range("A:A").SpecialCells(2)
            If cl.Value = week Then
                cl.Resize(10, 8).Copy
                shnaam = Trim(cl.Offset(1).Value)
                With Sheets(shnaam).Range("A:A")
                    Set Rng = .Find(week, LookIn:=xlValues, LookAt:=xlWhole)
                    If Not Rng Is Nothing Then
                        Rng.PasteSpecial
                    Else
                        MsgBox "Nothing found"
                    End If
                End With
            End If
        Next
    End If

End Sub

Niels

 

[eyeye]

Super dit is precies wat ik bedoel.