مساعدة فى الحلقة التكرارية داخل كود الترحيل لاتعمل

[simsim]

السلام عليكم 

برجاء المساعدة في تعديل الحلقة التكرارية الكود يقوم بترحيل السطر الاخير فقط لايقوم بترحيل الكل بناءا علي الشرط الموضح

Payment Requests2.xlsm

[محي الدين ابو البشر]

عليكم السلام

Sub CaloutDownArrow1_Click()

'On Error Resume Next

'Dim R As Integer
Dim M As Integer
Dim ws As Worksheet: Set ws = Sheets("Payment Requests")
Dim sh As Worksheet: Set sh = Sheets("Cash Position")
Dim cll As Range
 'R = ws.Cells(5000, 1)
 M = 1
For Each cll In ws.Range("J3:J1000")
If ws.Range("P1") = cll.Value Then
    sh.Cells(M, 13).Value = cll.Offset(0, -8)
    sh.Cells(M, 10).Value = cll.Offset(0, -6)
    sh.Cells(M, 2).Value = cll.Offset(0, -5)
    sh.Cells(M, 1).Value = cll.Offset(0, 0)
    sh.Cells(M, 5).Value = cll.Offset(0, 1)
    sh.Cells(M, 7).Value = cll.Offset(0, 2)
    sh.Cells(M, 3).Value = cll.Offset(0, 3)
    sh.Cells(M, 15).Value = cll.Offset(0, 5)
  '  On Error GoTo 0
  M = M + 1
End If

Next cll

End Sub

 

[simsim]

جزاك الله خيرا علي الاهتمام والرد