السلام عليكم
أخي أبوغازي تفضل الشرح
الكود يتكون من جزئين
الجزء الأول يتم تنفيذه آليا عند فتح المصنف ووظيفته هي كتابة التاريخ في ثلاثة خلايا وهي C3 , D3 , F3 الموجود في شيت التقرير اليومي
وهو كالآتي :
Sub Auto_open()
يعنى اجعل هذا الكود ينفذ آليا عند فتح المصنف
Sheets(2).[d3] = Date
اذهب للشيت رقم 2 ( التقرير اليومي ) وضع التاريخ في الخلية D3
Sheets(2).[f3] = "الموافق " & Format(Date, "yyyy/m/d")
اذهب للشيت رقم 2 وضع في الخلية F3 كلمة (موافق) وبجانبها التاريخ ولكن بالصيغة المبينة
Sheets(2).[c3] = Format(Date, "ddd")
اذهب للشيت رقم 2 وضع التاريخ في الخلية C3 ولكن بالكتابة وليس بالرقم ( يعني سبت , أحد وهكذا )
End Sub
انهاء الكود
الجزء الثاني : يتم فيه ترحيل البيانات من التقرير اليومي إلى شيت اس اف
وهو كالآتي :
Sub sf()
هذا الإجراء قمت أنا بتسميته بـ sf وبإمكانك أن تسميه بما شئت
Dim t As Integer, w As Integer, t1 As Integer, t2 As Integer, lr1 As Integer, u As Integer
الإعلان عن المتغيرات في هذا الكود
lr1 = Application.WorksheetFunction.Count(Sheets(3).Range("B6:B35"))
تطلب من الإكسل أن يحسب لك عدد الخلايا التي تحتوى على أرقام في النطاق B6:B35 الموجود في الشيت رقم 3 (اس اف)
For u = 6 To lr1 + 6
عمل حلقة تكرارية تبدا من اول سطر في النطاق B6:B35 إلى آخر سطر فيه
If Sheets(3).Range("B" & u).Text = Sheets(2).Range("D3").Text Then
ابحث في النصوص الموجودة في الشيت رقم 3 في النطاق B6:B35 فعندما يوجد نص مطابق للنص الموجود في الشيت رقم 2 والخلية D3 اعرض هذه الرسالة : لا يمكن الترحيل
MsgBox لا يمكن الترحيل""
وهذا يعنى أنه إذا وجد البرنامج التاريخ قد تم إدراجه سابقا فعند الضغط على زر (اس اف) سيقارن الكود هل التاريخ موجود مسبقا أم لا
إذا كان موجود يعنى أنه قد تم الترحيل مسبقا فستظهر رسالة : لا يمكن الترحيل
وبمعنى آخر أن الترحيل يتم مرة واحدة فقط
Exit Sub
ثم انهي العمل (هذا إذا كان التاريخ موجودا من السابق)
End If
Next
أما إذا لم يكن التاريخ موجودا فسيكمل الكود عمله كما في الأسفل
Sheets(3).Range("B" & 6 + lr1) = Sheets(2).Range("D3").Value
اذهب إلى أول خلية فارغة في النطاق B6:B35 الموجود في الشيت رقم 3 (الخاص بأول شركة) وضع فيه التاريخ الموجود في الشيت رقم 2 في الخلية D3
Sheets(3).Range("B" & 43 + lr1) = Sheets(2).Range("D3").Value
كرر نفس العمل السابق في النطاق الموجود في الشركة الثانية
Sheets(3).Range("B" & 80 + lr1) = Sheets(2).Range("D3").Value
كرر نفس العمل السابق في النطاق الموجود في الشركة الثالثة
ومعنى هذا أن الكود قام بكتابة التاريخ في كل جدول من الجداول الثلاثة الموجودة في شيت اس اف
نأتي الآن إلى نقل القيم من شيت التقرير اليومي (رقم2) إلى شيت اس اف (رقم 3)
أولا : الشركة الأولى
For t = 6 To 35
عمل حلقة تكرارية تبدأ من السطر رقم 6 إلى السطر رقم 35 وهو الخاص بالشركة الأولى في شيت اس اف
If Sheets(3).Range("B" & t) = Sheets(2).Range("D3").Value Then
إذا وجدت تاريخ في العمود B الخاص بالشركة الأولى يساوي التاريخ الموجود في الشيت 2 الخلية D3 قم بما يأتي
Sheets(3).Range("C" & t) = Sheets(2).[B6].Value
انقل القيمة الموجودة في الخلية B6 والشيت 2 إلى العمود C في الخلية المناسبة لها
(وهذا يعني انه سينقل الرقم 1)
Sheets(3).Range("E" & t).Resize(1, 2) = Sheets(2).[D10].Resize(1, 2).Value
انقل القيمتين في الخليتين D10 و E10 إلى المكان الخاص بهما في العمودين E , F
(وهذا يعني انه سينقل الرقمين 2 و 3)
Sheets(3).Range("G" & t) = Sheets(2).[B11].Value
انقل القيمة الموجودة في الخلية B11 والشيت 2 إلى العمود G في الخلية المناسبة لها
(وهذا يعني انه سينقل الرقم 4)
Sheets(3).Range("H" & t) = Sheets(2).[B13].Value
انقل القيمة الموجودة في الخلية B13 والشيت 2 إلى العمود H في الخلية المناسبة لها
(وهذا يعني انه سينقل الرقم 5)
End If
Next
ثانيا : الشركة الثانية : بنفس العمل السابق
For t1 = 43 To 72
عمل حلقة تكرارية تبدأ من السطر رقم 43 إلى السطر رقم 72 وهو الخاص بالشركة الثانية في شيت اس اف
If Sheets(3).Range("B" & t1) = Sheets(2).Range("D3").Value Then
Sheets(3).Range("C" & t1) = Sheets(2).[B23].Value
Sheets(3).Range("E" & t1).Resize(1, 2) = Sheets(2).[D27].Resize(1, 2).Value
Sheets(3).Range("G" & t1) = Sheets(2).[B28].Value
Sheets(3).Range("H" & t1) = Sheets(2).[B30].Value
End If
Next
ثالثا : الشركة الثالثة : بنفس العمل السابق
For t2 = 80 To 109
عمل حلقة تكرارية تبدأ من السطر رقم 80 إلى السطر رقم 109 وهو الخاص بالشركة الثالثة في شيت اس اف
If Sheets(3).Range("B" & t2) = Sheets(2).Range("D3").Value Then
Sheets(3).Range("C" & t2) = Sheets(2).[B40].Value
Sheets(3).Range("E" & t2).Resize(1, 2) = Sheets(2).[D44].Resize(1, 2).Value
Sheets(3).Range("G" & t2) = Sheets(2).[B45].Value
Sheets(3).Range("H" & t2) = Sheets(2).[B47].Value
End If
Next
MsgBox "تم الترحيل بنجاح"
بعد الانتهاء من الترحيل اعرض هذه الرسالة : تم الترحيل بنجاح
End Sub
انتهي عمل الكود
