Opgelost For Each...next loop werkt niet

[KeBr]

Beste in de bijlage kan in "E4" de startdatum van het project veranderd worden. Als dit gebeurt worden de shapes niet aangepast.

Ik heb een For Each... next loop gemaakt "Sub refresch()"maar deze werkt niet. Als ik met de macrorecorder een opname maak werkt dit wel. zie 2e deel "Sub Macro2()" hieronder. dit gaat echter niet werken voor max 300 regels.
Wat doe ik fout in de loop?

Sub refresch()
'
' shapes aanpassen op basi van nieuwe stardatum in E4
Dim w_dag As Range
For Each w_dag In ThisWorkbook.Sheets("Projectplanning").Range("G8:G38")
If w_dag.Value > 1 Then
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

End If
Next

End Sub

Sub Macro2()
'
'shapes aanpassen op basi van nieuwe stardatum in E4
Range("G8").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("G9").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("G10").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("G11").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("G12").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("G14").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub

 

[KeBr]

Na een opmerking hierbij de codes met tags

Sub refresch()
'
' shapes aanpassen op basis van nieuwe stardatum in E4
Dim w_dag As Range
    For Each w_dag In ThisWorkbook.Sheets("Projectplanning").Range("G8:G38")
    If w_dag.Value > 1 Then
        Selection.Copy
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        w_dag = w_dag + 1
        w_dag = w_dag - 1
        
    End If
Next
    
End Sub

Sub Macro2()
'
'shapes aanpassen op basi van nieuwe stardatum in E4
    Range("G8").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("G9").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("G10").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("G11").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("G12").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("G14").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End Sub

 

[AHulpje]

w_dag.Select tussenvoegen:

Sub refresch()
    ' shapes aanpassen op basis van nieuwe startdatum in E4
    Dim w_dag As Range
    For Each w_dag In ThisWorkbook.Sheets("Projectplanning").Range("G8:G38")
        If w_dag.Value > 1 Then
            w_dag.Select
            Selection.Copy
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        End If
    Next
End Sub

 

[snb]

Waarom geen autofilter ?

 

[KeBr]

AHulpje,

Bedankt voor je reactie, dat werkt prima.

@snb, met autofilter worden de cellen niet geactiveerd om de macro voor het plaatsen van Shapes opnieuw uit te voeren.

 

[snb]

Brrr. Van kwaad tot erger.