نجوم المشاركات

وجزيت خيراً بمثل ما دعوت لي أخي الكريم ناصر حددت العدد في الكود لوجود بيانات أسفل البيانات الأخرى عموماً إذا كنت تريد أن يكون مرتبط بآخر صف به بيانات في عمود محدد وليكن العمود الأول استبدل الرقم 140 بالسطر التالي Cells(rows.count,1).end(xlup).row حيث يقوم هذا الجزء بجلب رقم آخر صف به بيانات في العمود الأول .. إذا أردت عمود آخر قم باستبدال الرقم 1 في السطر السابق برقم العمود المطلوب .. أما إذا كنت تريد ربط المتغير بقيمة خلية في ورقة عمل أخرى .. اتبع التالي بفرض أن لديك في الورقة المسماة "Sheet1" في الخلية G5 القيمة المطلوبة ولتكن 410 سيتم الإشارة إلى ورقة العمل يليها الإشارة للخلية المطلوبة بهذا الشكل Sheets("Sheet1").Range("G5").Value ويستخدم هذا الجزء في هذه الحالة بدلاً من الرقم 410 في الكود

السلام عليكم فيه موضوع بعنوان الشرح المستفيض للمصفوفات http://yasserkhalilexcellover.blogspot.com.eg/2016/10/search-using-arrays.html أعتقد أنه سيفيدك في الموضوع إذا كنت تريد أداء أسرع من الحلقات التكرارية .. حاول فقط التركيز في الشرح وإن شاء الله تقدر تستفيد منه وفقكم الله جميعاً لما فيه الخير والصلاح

الأخ الكريم الأستاذ / محمد الدسوقى جرب الملف التالى لعلة يفى بالغرض abo_abary_ترحيل ناجح وراسب.rar

بالنظر إلى العلاقة بين الأفراد نجد الهيكل التنظيمي يكون كالتالي: وتكون الملفات موزعة كالتالي: طبعاً المشكلة لدينا هي عدم وجود ربط بين الملفات بالإضافة إلى عدم تمكن ابراهيم من الإطلاع على الملفات في أي وقت يريده.. ترقبوا الفكرة الأولى لإبراهيم .. تابعونا...........

بسم الله نبدأ.. تخيل يا أخي ابراهيم بأنك شغال في شركة لتوزيع المياه العذبة في مصر ولديك ثلاث مندوبين للتوزيع للمحافظات القريبة من الشإلاركة، وطبعاً من الطبيعي معرفة حركة المندوبين والكمية التي تم توزيعها، إلا أن ابراهيم لا توجد له طريقة للمتابعة إلا بالمرور على مكاتب المندوبين (مكتب مكتب.. جهاز جهاز.. ملف ملف) في الشركة وطلب تقرير اليومية منهم، وطبعاً تعتبر هذه العملية متعبة وروتينية تستنزف الوقت والمال، ففكر ابراهيم في طريقة لتوحيد التقرير.. كيف؟ تابعونا..........

السلام عليكمبتوفيق الله تم إعداد هذا الفيديوالذى هو أكثر احترافية لو أجدتم المهارات المشروحة فيهلاقترب بكم هذا من احتراف الأكسيس و إنجاز المهام به بكل سهولةتعرفون إدراج النموذج الفرعى داخل نموذج رئيسىفالنموذج الرئيسى به مثلا بيانات موظفو تحته نموذج فرعى يبين التدريبات التى حصل عليها الموظفهناك زر يفتح نموذجا يبين تفاصيل التدريب لكن فى حالة عدم وجود تدريبنحتاج لإخفاء هذا الزركيف يتم ذلك بالكودسنتعلم أيضا كيف نقرأ قيمة حقل فى نموذج فرعى و نستخدمهاأيضا فى حالة تعديل حقل فى النموذج الفرعى كيف نفتح نافذة نكتب فيها تفاصيل التدريبأرجو أن تنتفعوا بهذا الشرح وفقكم الله

السلام عليكم ورحمة الله وبركاته هدفيه للعاملين بالكنترولات المدرسيه ...... _ سجلات اعمال الكنترول كامله ... _ توزيع الملاحظين اليا على اللجان .... مع تحياتى ....

الاخوه الافاضل اريد طريقه تمكننى من العمل على الملف فى نفس الوقت مع مستخدم اخر عن طريق الشبكه مع العلم بان الملف يحتوى على اكواد vba تقبلو تحياتى

وعليكم السلام أخي صالح بالفعل فكرة جديدة ، وخارج عن المتعارف بس لو تسمح لي اقترح التالي: اعمل الحقول يدويا في التقرير ،وضبط المسافات ، واعطها ارقام مسلسله ، وعلى اساس العدد المطلوب ، اجعل بقية الحقول مخفية جعفر

يا سلام عليك استاذ صالح ‘ طريقة جديدة ومختلفة تماما ولا اروع . حولت عرض التقرير الى عمودي ، ولم يتبقى سوى سطر واحد في الصفحة الثانية وايضا الهامش الايمن كبير وهذا يعني اعادة النظر في المسافات بين الحقول عرضا وطولا استدراك : يلاحظ انه في كل مرة يفتح التقرير سوف يقوم بفتح التصميم وانشاء الحقول مرة اخرى والاولى ان يتم انشاؤها اول مرة فقط ، لانها باقية وموجودة فعلا ، فلو تم عمل شرط بذلك الا اذا اخذنا بالاعتبار تغير العدد المطلوب عرضه

Sub Test() Dim sh As Worksheet Dim i As Long Set sh = Sheets("بطاقة فردية") For i = 1 To sh.Cells(Rows.Count, 2).End(xlUp).Row _ Step 2 sh.Range("M3").Value = i ActiveWindow.SelectedSheets.PrintOut Copies:=1 Next i End Sub هل هيصبح الكود بهذا الشكل ؟

اهلا وسهلا بك في منتدى اوفيســـــــــــــــــــــــــــــــــــــــــــــــنا اعمل زر واكتب هذا في محرر فيجوال Private Sub أمر14_Click() If MsgBox("هل تريد طباعة الفاتورة؟", vbYesNo) = vbYes Then DoCmd.OpenReport "p", acViewNormal, , "[id]=forms!from_data!id" DoCmd.Save Else Exit Sub End If End Sub

جرب الكود التالي (ضع أسماء الملفات الجديدة في العمود المجاور في العمود الثاني قبل تنفيذ الكود) Sub RenameWBs() Dim strFolder As String Dim strFile As String Dim cel As Range Application.ScreenUpdating = False strFolder = ThisWorkbook.Path & "\" strFile = Dir(ThisWorkbook.Path & "\" & "*.xlsx") Do While strFile <> "" On Error Resume Next For Each cel In Worksheets(1).Range("A1:A" & Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row) If cel.Value = Replace(strFile, ".xlsx", "") Then Name strFolder & strFile As strFolder & cel.Offset(, 1).Value & ".xlsx" Exit For End If Next cel On Error GoTo 0 strFile = Dir Loop Application.ScreenUpdating = True End Sub

موضوع قد يهمك

دا ملف لأخونا ياسر العربي بخصوص هذا الموضوع Convert SUMIF To VBA.rar من جاور القوم أربعين يوووووم صار منهم وإحنا قربنا على أربعين سنة .. يدينا ويديلك طولة العمر أكبير

أخى الحبيب ياسر وحشتنى والله وكل منتدى أوفيسنا وحشنى جدا ما صدقت ارتحت شوية من ضغوط العمل وقلت أرجع لهوايتى المفضلة تحياتى للجميع بس ايه حكاية أنا مش مسدس نفسى دى هوا انت من بلشاى ولا ايه ههههههههههههههه

وعليكم السلام مش مصدق عيني ..يمكن بحلم!!! استنى كدا .. قرصت نفسي يعني صاحي !! أنا مش مسدس نفسي :) عوداً حميداً يا أستاذنا الكبير .. والله ليك وحشة كبيرة

اخى الزبارى نحن في الانتظار...

تم رفع هذا الكود فى مشاركة منفصله حتى لا ننسى هذه المشاركة تم ارفاق كود الحل من الفاضل _ ا / ابو اسامة العينبوسي Private Sub Worksheet_SelectionChange(ByVal Target As Range) Sheets(1).Protect Password:="Secret", UserInterfaceOnly:=True Sheets(1).Cells.Locked = True If Sheets(1).Cells(ActiveCell.Row, ActiveCell.Column).Value = vbNullString Then Sheets(1).Cells(ActiveCell.Row, ActiveCell.Column).Locked = False End Sub مرفق الملف Lock.zip و لا تنسونا من صالح الدعاء تحياتى

وهذه اضافة مع اخوي جعفر وجدتها عندي .. لاحظ حجمها كبير جدا لاحتوائها على صور 1 واجهات.rar

استعمال الدالة VLookup في البحث باستخدم الكود وباستخدم الفورم استعمال الدالة VLookup في البحث باستخدم الكود.rar

تزيدنا شوقا وتعلقا بك اخي الزباري نحن في الانتظار وفقك الله

الأخ الفاضل الأستاذ / زيزو العجوز الأخ الفاضل الأستاذ / أبو عبد البارى ---------------------------------------------------- السلام عليكم ورحمة الله وبركاته -------------------------------------------------------- تعجز الكلمات عن مدى شكرى وامتنانى لكما على هذين الكودين أنقذتمونى من بحر المعادلات التى قمت بتطبيقها و التى تؤثر سلبا على حجم الملف وسرعته جزاكم الله خيرا أحبتى فى الله وجعلكم الله عونا لنا دائما على الخير ما حيينا ملحوظة صغيرة : على كود الأستاذ الفاضل زيزو العجوز لمن يريد العمل على نفس الملف المرفق قم بتغيير الر قم ( n=11)فى الكود إلى ( n=10), وكذلك ( n-11)فى الكود إلى ( n-10) وفقكم الله دائما إلى الخير والسداد

وعليكم السلام هذه عندي من سنين ، ولا اعرف من اين اتيت بها ، ولم استعملها ، ولا اعرف استعمالها ، ولا ولا .... ، يعني لا تسألني اي شئ عنها جعفر ShapedForm2k.zip wipeeffects2k.zip

Sub TranResult1() ' الكود من ابداع المحترم زيزو العجوز 'الهدف من الكود استخراج الناجحين عن طريق قائمه منسدله 'تم عمل هذا الكود في 7/1/2017 Sheet8.Range("A12:Z500").ClearContents Dim An As Variant, Ar As Variant, LR As Long, R As Integer Application.ScreenUpdating = False Sheet3.Activate LR = Range("C" & Rows.Count).End(xlUp).Row An = Array(2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 19, 29, 39, 50, 61, 69, _ 73, 78, 83, 88, 93, 99) For i = LBound(An) To UBound(An) n = 11 For R = 12 To LR If Cells(R, "M") = "ناجح" Then n = n + 1 With Sheet8 .Cells(n, "A") = (n - 11) .Cells(n, i + 2) = Cells(R, An(i)) End With End If Next Next Sheet8.Select Application.ScreenUpdating = True End Sub جزاك الله خيرا ونتعشم في شرح اسطره

السلام عليكم ورحمة الله اتمنى من الله عز وجل ان يكون هذا هو المطلوب ترحيل ناجح وراسب.rar

انظر الى المرفق يمكن استخراج التكرار حسب ما تريد (نص أو أرقام) لتعمل المعادلة بعد نسخها على العدد الكبير (5000 صف) يجب توسيع النطاق الى A5000 مع استعمال (Ctrl+Shift+enter)للمعادلة لانها معادلة صفيف الحل في الصفحة Salim من المرفق TEKRAR COUNT 1.rar

السلام عليكم و رحمة الله تعالى و بركاته. أخي الأستاذ محمد أيمن بعد إذنك أريد المشاركة معكم في هذا الموضوع: يمكن أيضا تنفيذ البحث عن ملف داخل الجهاز بهذا الكود: If Dir("D:\1.txt") = "" Then MsgBox "عذرا ملف الحماية غير موجود", vbCritical Quit End If

عُدنا والعَود أحمدُ بالنسبة لطلب أخي ابراهيم ابوليله في سرد مثال قصصي على ذلك، وبالرغم أنني لا أحسن القصص، إلا أنني سأحاول ذلك من أجل تقريب المعلومة مستعيناً بذلك ببعض الرسومات التوضيحية التي ستختصر فصول القصة بالرغم من طولها، وليسمحني الجميع بأن أبتعد عن التعامل مع الفورم في الشرح لأنه سيتضح لنا عدم الحاجة له، تابعووووونا.

وعليكم السلام ورحمة الله وبركاته اختي ، انا لست من مشجعي حفظ المرفق في الجدول ، لذلك لا املك خبرة كافية في هذا الموضوع ، لذا ، بحثت ووجدت مثال ، وقمت بتعديل المثال ليناسب مع طلبك الكود التالي به وحدتان نمطيتان: الاولى: CopyAttachment (الوحدة النمطية الاصلية) ، لعمل نسخة من المرفق الى حقل في سجل جديد آخر ، وهكذا يستعمل: ومثلا نريد نسخ المرفق في الحقل fld_1 في الجدول tbl_1 ، من السجل الذي Emp=25 (هذا الحقل غير الزامي ، فيمكن تجاهله وتركه فارغا) ، الى الحقل fld_2 في tbl_2 ، call CopyAttachment("tbl_1", "fld_1", _ "tbl_2", "fld_2", _ "Emp=25") . الثانية: UpdateAttachment (الوحدة النمطية التي عدلت عليها) ، لتحديث حقل موجود اصلا ، ووهكذا يستعمل: ومثلا نريد نسخ المرفق في الحقل fld_1 في الجدول tbl_1 ، من السجل الذي Emp=25 ، وتحديث الحقل fld_2 في tbl_2 ، الى السجل الذي Emp=30 " call UpdateAttachment("tbl_1", "fld_1", _ "tbl_2", "fld_2", _ "Emp=25", "Emp=30") . والوحدتان النمطيتان هما: Option Compare Database 'from 'http://www.access-programmers.co.uk/forums/showpost.php?p=1465813&postcount=3 ' Public Sub CopyAttachment(ByVal strTableSource As String, _ ByVal strSourceAttachmentField As String, _ ByVal strTableTarget As String, _ ByVal strTargetAttachmentField As String, _ Optional ByVal strCondition As String = "") Dim rstFrom As DAO.Recordset2 Dim rstTo As DAO.Recordset2 Dim rstMVF As DAO.Recordset2 Dim rstMVT As DAO.Recordset2 Dim strSQL As String Dim db As DAO.Database strSQL = "SELECT * FROM " & strTableSource Set db = CurrentDb If strCondition <> "" Then strSQL = strSQL & " WHERE " & strCondition End If Set rstFrom = db.OpenRecordset(strSQL, dbOpenDynaset) Set rstTo = db.OpenRecordset(strTableTarget, dbOpenDynaset) Do While rstFrom.EOF = False rstTo.AddNew 'rstTo!Description = rstFrom![Description] Set rstMVF = rstFrom(strSourceAttachmentField).Value Set rstMVT = rstTo(strTargetAttachmentField).Value ' Copy all the attachment in the field (attachment datatype) Do While rstMVF.EOF = False rstMVT.AddNew rstMVT!FileData = rstMVF!FileData rstMVT!FileName = rstMVF!FileName '********************************* ' below fields are not updateable ' 'rstMVT!FileFlags = rstMVF!FileFlags 'rstMVT!FileTimeStamp = rstMVF!FileTimeStamp 'rstMVT!FileType = rstMVF!FileType 'rstMVT!FileURL = rstMVF!FileURL ' '********************************* rstMVT.Update rstMVF.MoveNext Loop rstMVF.Close rstMVT.Close Set rstMVF = Nothing Set rstMVT = Nothing rstTo.Update rstFrom.MoveNext Loop rstFrom.Close rstTo.Close Set rstFrom = Nothing Set rstTo = Nothing Set db = Nothing End Sub ' 'modified by jjafferr to include a condition for both source and destination tables '04-01-2017 ' Public Sub UpdateAttachment(ByVal strTableSource As String, _ ByVal strSourceAttachmentField As String, _ ByVal strTableTarget As String, _ ByVal strTargetAttachmentField As String, _ ByVal strCondition_s As String, _ ByVal strCondition_d As String) Dim rstFrom As DAO.Recordset2 Dim rstTo As DAO.Recordset2 Dim rstMVF As DAO.Recordset2 Dim rstMVT As DAO.Recordset2 Dim strSQL_Source As String Dim strSQL_destination As String Dim db As DAO.Database strSQL_Source = "SELECT * FROM " & strTableSource strSQL_destination = "SELECT * FROM " & strTableTarget Set db = CurrentDb 'If strCondition <> "" Then strSQL_Source = strSQL_Source & " WHERE " & strCondition_s strSQL_destination = strSQL_destination & " WHERE " & strCondition_d 'End If Set rstFrom = db.OpenRecordset(strSQL_Source, dbOpenDynaset) Set rstTo = db.OpenRecordset(strSQL_destination, dbOpenDynaset) Do While rstFrom.EOF = False rstTo.Edit 'rstTo!Description = rstFrom![Description] Set rstMVF = rstFrom(strSourceAttachmentField).Value Set rstMVT = rstTo(strTargetAttachmentField).Value ' Copy all the attachment in the field (attachment datatype) Do While rstMVF.EOF = False rstMVT.AddNew rstMVT!FileData = rstMVF!FileData rstMVT!FileName = rstMVF!FileName '********************************* ' below fields are not updateable ' 'rstMVT!FileFlags = rstMVF!FileFlags 'rstMVT!FileTimeStamp = rstMVF!FileTimeStamp 'rstMVT!FileType = rstMVF!FileType 'rstMVT!FileURL = rstMVF!FileURL ' '********************************* rstMVT.Update rstMVF.MoveNext Loop rstMVF.Close rstMVT.Close Set rstMVF = Nothing Set rstMVT = Nothing rstTo.Update rstFrom.MoveNext Loop rstFrom.Close rstTo.Close Set rstFrom = Nothing Set rstTo = Nothing Set db = Nothing End Sub . جعفر 522.نقل نسخة.accdb.zip

جميييل جداً.. الآن كل ما عليك فعله هو إعطاء نسخة (ملف الإكسيل فقط ) لأي مستخدم تريده ان يشاركك الملف، حيث أصبح كل مستخدم له نسخته الخاصة ويستسطيع استخدامها بشكل منفصل ولا علاقة له ببقية المستخدمين، ويتم التعامل مع المجلد الذي نقلناه إلى الشبكة، حيث يقوم ملف الإكسيل بالإستعلام عن البيانات مؤقتاً عن طريق المجلد الموجود على الشبكة، ومن الممكن عمل ملفات اكسيل مختلفة تحدد صلاحية كل مستخدم.. تابعونا لمعرفة كيفية التعامل مع الملفات النصية (txt.*) وتعديلها أو استدعائها وحذفها أو نسخها إلى مل نصي آخر. تحياتي

السلام عليكم احببت المشاركة في هذا الموضوع ، لأني قمت بمثل هذا العمل مسبقا في بعض برامجي طبعا قمت بعمل بعض التغييرات في الجداول!! النموذج التالي يقوم بكل العمل: . عمل النموذج اسهل من شرحه 1. حقل تاريخ الاجازة ، 2. حقل سبب الاجازة ، 3. حقل نوع الاجازة ، 4. زر لتصفية البيانات 1 و 2 و 3 و 6 ، 5. الخورج من النموذج ، 6. في جدول Emp ، اضفت حقل اسم القسم الذي يشتغل فيه الموظف ، لذا هنا نستطيع ان نختار القسم ، 7. وعند الضغط على الزر عرض ، فسترى اسماء جميع موظفي القسم في الحقل 9 ، 8. زر تصفية الاسماء التي تم اختيارها ، 9. يمكن اختيار كل موظف على حدة ، بكتابة اسمه ، وتلقائيا سترى القسم الذي يعمل فيه (فقط لعدم اختيار الموظف الخطأ) ، 11. يمكن حذف اي سجل من السجلات المختارة ، 10. فقط عند الضغط على هذا الزر ، يتم ادخال الاجازات الى جدول الاجازات ، وإلا ، فجميع السجلات تظل في الجدول المؤقت tbl_Temp ، والذي تُحذف سجلاته تلقائيا عند الخروج من النموذج ، جعفر 510.اضافة اكثر من موظف في ان واحد.accdb.zip

السلام عليكم اليكم الطريقة كاملة نقوم بانشاء ملفات مثلا كتالي نفتح ملف الاكسل ولنفرض المشتريات ونقوم بعمل الفورم المطلوب للعمل نكر العملية لجميع الملفات المطلوبة نحفظ الملف ونقوم بتفح قاعد ةالبيانات واتبع الصورة / يجب ان يكون هناك جدول واحد على الاقل في القاعدة ليقبل الخيار الاخير كرر العملية نفسها لجميع الملفات اصبح لدينا الان ثلاث جداول اكسل داخل قاعدة البيانات افتح تصميم استعلام واتبع الصورة يجب ان تقوم باضافة جميع الخانات الى الاستعلام لكل جدول استعلام خاص به اخيرا قم باختيار طريقة عرض SQL وانتبه الى جميع الاضافات ان تكون موجودة ثم احفظ كرر العملية نفسها ليصبح لديك 3 استعلامات افتح ملف الاكسل باسم مدير واتبع الصورة حدد الاستعلام المطلوب واتبع الصور تم استيراد البيانات بنجاح الان قم بفتح ملف المشتريات مثلا واكتب به ثم احفظ اذهب الى صفحة المدير واختر بيانات وتحديث الكل وشاهد النتيجة مبروك عليك انتهى الشرح الان فكر بعمق كيف تستطيع ربط جمع الصفخات او المستخدمين ببرنامجك حسب ماتريد انت وشكرا تحميل الصور والملفات والشرح http://www.up-00.com/?rIXR ايضا تستطيع رفع قاعدة البيانات على الشيربونت او موقع مشاركة للعمل على الشبكة او الانترنت مثلا انت في مصر والموظف في السعودية والمراقب في سوريا يستطيعون العمل معا على قاعدة واحدة عبر الشير بونت او موقع مشاركة وشكرا

توجد طريقة وحيدة، وهي تقسيم الملف إلى عدة ملفات منفصلة (ملفين أو ثلاثة)،ملف للمستخدم يقوم بإدخال البيانات والتعديل عليها واستعلام البيانات، وهذا الملف يكون للقراءة فقط، والملف الثاني لتسجيل البيانات وموجود على الشبكة (السيرفر) والملف الثالث لتحديث البيانات وتجميعها موجود على السيرفر، لم أجربها ولكن من خلال اطلاعاتي ومحاولاتي الجزئية ستنجح.. وجاري إرسال ملف مصغر عن الفكرة. تحياتي

أخي الكريم أبو حمادة يرجى فيما بعد في أي موضوعات قادمة أن يكون الملف المرفق معبر عن الملف الأصلي .. لاحظ أنني طلبت منك أكثر من مرة إرفاق ملف وفيه المعادلات في الخلايا الخضراء ولم تستجب ، فهل إذا لم تستجب لمطلبي ترى هل يمكن أن أستجيب لمطلبك ؟؟!! راعي الآخرين كما تحب أن يراعيك الآخرون جرب الكود التالي عله يفي بالغرض (الكود استغرق مني أكثر من 3 ساعات فلا تنسانا بدعوة بظهر الغيب) Sub Filter_Transfer_Data() Const nGroup As Long = 25 Const nInsert As Long = 3 Dim Ws As Worksheet, Sh As Worksheet Dim myDate1 As Date, myDate2 As Date Dim arr1 As Variant, arr2 As Variant Dim I As Long, J As Long, P As Long Set Ws = Sheets("add") Set Sh = Sheets("Aldata") Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next Sheets("Temp").Delete Sheets.Add.Name = "Temp" On Error GoTo 0 If IsDate(Sh.Range("W2")) And IsDate(Sh.Range("W3")) Then myDate1 = Sh.Range("W2"): myDate2 = Sh.Range("W3") myDate1 = DateSerial(Year(myDate1), Month(myDate1), Day(myDate1)) myDate2 = DateSerial(Year(myDate2), Month(myDate2), Day(myDate2)) End If With Ws .AutoFilterMode = False .Range("A2:R2").AutoFilter Field:=15, Criteria1:=">=" & myDate1, Operator:=xlOr, Criteria2:="<=" & myDate2 .Range("A2:R2").AutoFilter Field:=17, Criteria1:=Sh.Range("U3").Value .Range("A2").CurrentRegion.Offset(1).SpecialCells(xlCellTypeVisible).Copy Sheets("Temp").Range("A1") .AutoFilterMode = False End With On Error Resume Next Sh.Range("A6:R10000").SpecialCells(xlCellTypeConstants).ClearContents arr1 = Sheets("Temp").Range("A1").CurrentRegion.Value I = ((UBound(arr1, 1) \ nGroup) + 1) * (nGroup + nInsert) arr2 = Sh.Range("A6").Resize(I, UBound(arr1, 2)).Formula For I = 1 To UBound(arr1, 1) P = P + 1 For J = 1 To UBound(arr1, 2) arr2(P, J) = arr1(I, J) Next J If I Mod nGroup = 0 Then P = P + nInsert Next I Sh.Range("A6").Resize(UBound(arr2, 1), UBound(arr2, 2)).Formula = arr2 Sheets("Temp").Delete Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub تقبل تحياتي

معذرة اخونا رعد على التأخر في الرد والسبب ان المرفق على اصدار احدث من 2003 فاضطررت الى نقله الى جهاز آخر والسبب في هذا العدد الهائل في التحميل نسبة الى الزمن اليسير يرجع فيما اعتقد الى هذا العنوان الشيق الذي اخترته لموضوعك اما طريقة التنفيذ فالطرق متعددة وكل يأخذ في الطريق الذي يناسبه وأرى من وجهة نظري انك لست بحاجة الى علاقات بين الجداول فقط يلزمك حقل نصي في جدول الشهور للسنة المالية مثلا 2013 ويتم تحديثه على رأس السنة اما الزيادات في راتب الفرد حين يأخذ علاوة في منتصف الشهر مثلا فهذه يتم اعداد تقرير اقرادي بالفروقات ولكن دعنا من الفروقات والزيادات والعلاوات والترقيات .. لنفترض ان الرواتب والامور المالية لن تتغير خلال اشهر قادمة : 1- كيف نعمل تقارير (مسيرات) لكل شهر بضغطة زر مع مراعاة عدم التكرار ؟ 2- كيف نحافظ على البيانات المالية التاريخية للشهور السابقة عند اجراء التغييرات على اصل المستحقات ج1 - باستخدام الاستعلام الالحاقي ويراعى جعل رقم الموظف والشهر والسنة مفاتيح في جدول الرواتب ج2- البيانات التاريخية لن تتأثر لان جدول الرواتب مستقل