توزيع صفوف صفحه على مجموعة صفحات

[أبو وليد]

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

 

مساء الخير

 

توزيع صفوف صفحه على مجموعة صفحات عن طريق زر أمر كما في المرفق

12.rar

تم تعديل نوفمبر 22, 2014 بواسطه أبو وليد

[ابو تراب]

وعليكم السلام

 

هلا ابو وليد

 

جرب الكود المرفق.

 

 

12.zip

[أبو وليد]

بارك الله فيك

 

يتم الترحيل بشكل ممتاز

 

مع ملاحظة

لو افت عمود واحد ورحلت يعيد الترحيل مره اخرى وفي موجود نفس التاريخ سابقا

يتم الترحيل في اخر خليه

[ابو تراب]

هلا ابو ليد

 

ممكن توضح اكثر .. وخصوصا التاريخ...ماذا تعني بالعبارة "لو افت عمود واحد" .. عذرا لم افهمها..

 

المقارنة تعتمد على قيمة العمود B

[أبو وليد]

اقصد أن يرحل التاريخ الجديد فقط

التاريخ الموجود سابقا لا يرحل

 

أن يرحل في الصف الاول وليس الاخير

 

عدد الصفوف في الصفحه تتوقف عند 5 ويتم استبادال اخر صف

 

ياليت تشرح الكود عشان اغير بدون ازعاجكم

تم تعديل نوفمبر 23, 2014 بواسطه أبو وليد

[ابو تراب]

عدلت في الكود ... حمل الملف وجرب .. ان شاء الله يعمل

 

ملاحظة: في الشيت Main يوجد تاريخ مكرر ل 1002 تم تعليمه بالاحمر

 

شرح سريع للكود:

 

Option Explicit


Sub Button1_Click()
Dim LR As Integer
Dim i As Integer
Dim sheetNum As Integer
'احصل على عدد الاسطر في الصفحة Main
LR = [A1000].End(xlUp).Row


'احصل على الرقم الصفحة التسلسلي بطرح اسمها العددي (مثلا 1001) من 999 فيكن الناتج 2 لصفحة 1001 و 3 لصفحة 1002 و هكذا
For i = 2 To LR
   sheetNum = Range("A" & i) - 999
' تاكد من عدم و جود التاريخ في الصفحة المراد الترحيل اليها.    
   If doesRecordExist(sheetNum, Range("B" & i)) = False Then
' اضف سطر جديد و ادفع اسطر الجدول للاسف      
      Sheets(sheetNum).Range("A2:E2").Insert
' انسخ السطر من الجدول الرئيسي الى السطر الاول
      Range("A" & i & ":E" & i).Copy Sheets(sheetNum).Range("A2")
' احدف السطر رقم 7 للمحافضة على 5 اسطر فقط في كل جدول
      Sheets(sheetNum).Range("A7:E7").Delete
   
   End If
   
Next i


MsgBox "Êã ÇáÊÑÍíá ÈäÌÇÍ", vbInformation + vbOKOnly, "ÊÑÍíá ÇáÈíÇäÇÊ"


End Sub


' دالة التأكد من عدم وجود التاريخ في الجدول المراد الترحيل اليه
Private Function doesRecordExist(sheetNum As Integer, datDate As String)
Dim LR As Integer
Dim i As Integer
Dim isFound As Boolean


LR = Sheets(sheetNum).[A1000].End(xlUp).Row


isFound = False


For i = 2 To LR
   isFound = Sheets(sheetNum).Range("B" & i) = datDate
    
   If isFound Then Exit For
    
Next i


doesRecordExist = isFound
End Function

 

NEW 12.zip

[أبو وليد]

بيض الله وجهك

 

الله يسعدك ويوفقك رائع جدا