كود ترحيل صف من شيت لأخر بناء على قيمة خلية

Option Explicit

Sub trans_data()

Const mot$ = "DELIVERED"

Dim Source_Sheet As Worksheet

Dim Target_Sheet As Worksheet

Dim Rs_Copy As Range, Cel As Range

Dim dic As Object, ky

Dim Rs%, n%, Rt%

Dim arr As Variant



Set Source_Sheet = Sheets("ONGOING")

Set Target_Sheet = Sheets("DELIVERED")

Set dic = CreateObject("Scripting.Dictionary")

Set Rs_Copy = Source_Sheet.Range("a2").CurrentRegion

Rs = Rs_Copy.Rows.Count

Rt = Target_Sheet.Cells(Rows.Count, 1).End(3).Row + 1

If Rt = 2 Then Rt = 3

If Rs = 1 Then Exit Sub

Set Rs_Copy = Rs_Copy.Offset(1).Resize(Rs - 1)

For Each Cel In Rs_Copy.Columns(15).Cells

 If UCase(Cel) = mot Then

 n = n + 1

   arr = Application.Transpose(Cel.Offset(, -13).Resize(, 15))

   arr = Join(Application.Transpose(arr), "*")

   dic(n) = arr

 End If

 Next

 If dic.Count Then

    For Each ky In dic.keys

      Target_Sheet.Cells(Rt, 1) = ky

      Target_Sheet.Cells(Rt, 2).Resize(, 15) = _

       Split(dic(ky), "*")

      Target_Sheet.Cells(Rt, "Q") = Date

      Rt = Rt + 1

    Next

 End If

 

End Sub