Cellen verplaatsen indien aan voorwaarde wordt voldaan.

[arierood]

Goedemiddag,
Is het mogelijk om vanuit Blad1 een aantal cellen in een rij, zeg A2 t/m Q2, te laten verplaatsen en in te voegen naar Blad2 ook A2 t/m Q2, indien in Q2 aan een voorwaarde wordt voldaan, b.v. "JA" wordt geselecteerd? Is het dan ook mogelijk om een Msgbox met ja/nee in te bouwen, voordat de handeling werkelijk plaatsvindt?
Ik weet redelijk hoe ik macro's moet opnemen, maar kom er niet uit door die voorwaarde. Graag jullie zeer gewaardeerde hulp daarbij. Gr. Arie

 

[HSV]

Bedoel je zoiets?

 

[Warme bakkertje]

Kleine variant. De voorwaarde geldt voor de hele Q-kolom, de regel wordt verplaatst naar de overeenkomstige regel en elke variant van de voorwaarde (ja , Ja, jA, JA) wordt aanvaard.

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Err1:
If Target.Column = 17 And UCase(Target.Value) = "JA" Then
    If MsgBox("Wilt u deze regel verplaatsen ?", vbYesNo + vbInformation) = vbYes Then
        Sheets("Blad2").Range("A" & Target.Row).Resize(, 17) = _
            Sheets("Blad1").Range("A" & Target.Row & ":Q" & Target.Row).Value
        Target.EntireRow.Delete xlUp
    Else
        Exit Sub
    End If
End If
Err1:
End Sub

 

[arierood]

Weer bedankt voor het meedenken!
Helemaal goed op één dingetje na. De regel wordt verplaatst, maar overschreven op het moment er nog een regel wordt verplaatst. Ik wil de verplaatste regels nog wel even bewaren, dus eigenlijk is er sprake van een archief. De regel moet dus worden ingevoegd, zodat de eventueel al aanwezige andere regels in het archief wel worden bewaard. Is dit ook nog mogelijk? Gr. Arie

 

[Warme bakkertje]

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Err1:
If Target.Column = 17 And UCase(Target.Value) = "JA" Then
    If MsgBox("Wilt u deze regel verplaatsen ?", vbYesNo + vbInformation) = vbYes Then
        Sheets("Blad1").Range("A" & Target.Row & ":Q" & Target.Row).Copy
        Sheets("Blad2").Range("A" & Target.Row).Insert
        Target.EntireRow.Delete xlUp
    Else
        Exit Sub
    End If
End If
Err1:
End Sub

 

[arierood]

:thumb:dankjewel