ترحيل بيانات

[elsawe]

اخواني السلام عليكم ورحمة الله وبركاته

ارجو المساعدة في ترحيل جزء معين من البيانات وإبقاء البيانات التي لا ينطبق عليها الشرط

مرفق ملف توضيحي

وشكرا

كشف حساب العملاء.xlsx

[ابراهيم الحداد]

السلام عليكم ورحمة الله

استخدم هذا الكود

Sub Tarhil()
Dim ws As Worksheet, Sh As Worksheet
Dim Arr As Variant, Temp As Variant
Dim LR As Long, i As Long, j As Long, p As Long
Dim Setlt As String
Set ws = Sheets("كشف السداد")
Set Sh = Sheets("حساب العملاء")
Setlt = "تم السداد"
LR = ws.Range("B" & Rows.Count).End(xlUp).Row
Arr = ws.Range("B5:F" & LR).Value
ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
For i = 1 To UBound(Arr, 1)
If Arr(i, 5) = Setlt Then
p = p + 1
For j = 1 To 4
Temp(p, j) = Arr(i, Choose(j, 1, 2, 3, 5))
Next
End If
Next
If p > 0 Then Sh.Range("B4").Resize(p, UBound(Temp, 2)).Value = Temp
End Sub