السلام عليكم اخوااتى
استاذ ياسر ربنا يكرمه هو والاستاذ سليم ربنا يحفظكم يارب
احتاج تعديل عى كود الترحيل الذى اهدانى اياه اخى فى الله الاستاذ ياسر
انا حاولت كتير من امس وفشلت
عدلت حاجة واحدة ونجحت عندما تكون خلية a2 التاريخ فرغة الكود يقف ويخرج رسالة برجاء ادخال التاريخ وللامانة احد الاخوة الى عليها
احتاج عندما تكون خلية c2 فارغة ايضا يقف ويكتب رجاء ادخال رقم الفاتورة
ايضا f2 اذا كانت فارغة برجاء اختيار المخزن
واذا تم الكتابة فىb3 ولم يكتب فىd3 وe3 برجاء اكمال البيانات
وهكذا مع باقى الاسطر
لتجنب نسيان اى بيان لان الكود يرحل بغض النظر هل البيانات كاملة او لم تكتمل
لا احتاج تعديل فى كود الترحيل الكود يعمل ممتاز بس احتاج تنبيه باكمال البيانات
مع خالص الشكر والتقدير
Sub Test()
Dim x, ws As Worksheet, sh As Worksheet, sName As String, r As Long, m As Long, n As Long, rng As Range
Set rng = Sheet1.Range("A2")
If rng.Value = "" Then MsgBox "اكتب التاريخ من فضلك", vbExclamation: Exit Sub
'إيقاف اهتزاز الشاشة
Application.ScreenUpdating = False
'ورقة العمل المسماة صفحة الترحيل
Set ws = Sheet1
'المتغير لمعرفة رقم آخر صف به بيانات في العمود الثاني
m = ws.Cells(Rows.Count, "B").End(xlUp).Row
'حلقة تكرارية من الصف رقم 3 إلى آخر صف به بيانات
For r = 3 To m
'متغير لتخزين اسم ورقة العمل التي سيتم الترحيل إليها
sName = ws.Cells(r, 5).Value
'التأكد من وجود ورقة العمل التي سيتم الترحيل إليها
If Evaluate("ISREF('" & sName & "'!A1)") Then
'تعيين ورقة العمل التي سيتم الترحيل إليها
Set sh = ThisWorkbook.Worksheets(sName)
'تحديد أول صف فارغ في ورقة العمل المراد الترحيل إليها لوضع البيانات بها
n = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1
With sh
'ترحيل التاريخ
.Cells(n, 1).Value = ws.Cells(2, 1).Value
'ترحيل الاسم
.Cells(n, 2).Value = ws.Cells(r, 2).Value
'ترحيل رقم الفاتورة
.Cells(n, 3).Value = ws.Cells(2, 3).Value
'معرفة رقم العمود الخاص بالمخزن ليتم إدراج المبلغ فيه
x = Application.Match(ws.Cells(2, 6).Value, sh.Rows(1), 0)
If Not IsError(x) Then
.Cells(n, x).Value = ws.Cells(r, 4).Value
End If
End With
Else
Debug.Print "Worksheet " & sName & " Doesn't Exist"
End If
Next r
'استعادة خاصية اهتزاز الشاشة
Application.ScreenUpdating = True
Range("A3:f24").ClearContents
MsgBox "تم الترحيل بنجاح", 64, ""
End Sub