ترحيل بشرط

[محمد الورفلي1]

السلام عليكم

اريد عدم الترحيل اذا كانت احدى خلايا العمود d  فارغة

 

Sub حفظ()
Application.ScreenUpdating = False
Dim Lr As Integer
Lr = [A10000].End(xlUp).Row
Range("A3:i" & Lr).Copy
Sheets("مخزن").Range("A" & Sheets("مخزن").[A10000].End(xlUp).Row + 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
MsgBox "تم الحفظ بنجاح", vbOKOnly, "تنبية"
Range("A3:e10000").ClearContents

End Sub

 

ترحيل بشرط.rar

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

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

استبدل الكود السابق بهذا الكود

Sub حفظ()
Application.ScreenUpdating = False
Dim Lr As Integer, C As Range
Lr = [A10000].End(xlUp).Row
For Each C In Range("D3:D" & Lr)
If C.Value = "" Then
MsgBox "يوجد بعض البيانات الناقصة بعمود العدد"
Exit Sub
End If
Next
Range("A3:i" & Lr).Copy
Sheets("مخزن").Range("A" & Sheets("مخزن").[A10000].End(xlUp).Row + 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
MsgBox "تم الحفظ بنجاح", vbOKOnly, "تنبية"
Range("A3:e10000").ClearContents

End Sub

 

[محمد الورفلي1]

7 دقائق مضت, زيزو العجوز said:

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

استبدل الكود السابق بهذا الكود

Sub حفظ()
Application.ScreenUpdating = False
Dim Lr As Integer, C As Range
Lr = [A10000].End(xlUp).Row
For Each C In Range("D3:D" & Lr)
If C.Value = "" Then
MsgBox "يوجد بعض البيانات الناقصة بعمود العدد"
Exit Sub
End If
Next
Range("A3:i" & Lr).Copy
Sheets("مخزن").Range("A" & Sheets("مخزن").[A10000].End(xlUp).Row + 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
MsgBox "تم الحفظ بنجاح", vbOKOnly, "تنبية"
Range("A3:e10000").ClearContents

End Sub

 

تمام التمام

شكراً بارك اله فيك