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

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

السلام عليكم اخي طاهر انا ربما اختلف قليلا عن بقية اخوتي الخبراء والاعضاء هنا الغالب هنا يختصرون عليك وعليهم الوقت ويعطونك حل للمشكلة التي تواجهك مباشرة .. ولكن في بعض الاحيان المشكلة اذا لم تعالج من الاصل .. فإنها تولد مشكلات واخطاء تتبعها حينما استعرض مثالك لا يمكنني فهم آلية العمل : خذ ما دار في بالي : اولا لماذا الاقتطاع وتخصيصه شهري 3 و 7 فقط ... يجب ان نفهم لماذا؟ يجب ان يكون الجواب مقنع علما انه ومن خلال الجدول يوجد اقتطاعات في اشهر اخرى لا يخفى عليك . معظم .. بل كل .. عمليات القروض التي تخص العاملين والموظفين في كل الأنظمة يتم اقتطاعها من المرتب شهريا .. الى ان يتم تسديد كامل القرض مثلا اذا الموظف مطالب بتسديد 3000 دينار سنويا .. ستكون الحصة الشهرية 250 دينار تخصم من مرتبه آليا حتى لو هناك قروض اخرى يضاف استحقاقها الشهري في عمود يخصها .. والنتيجة ان الموظف يستلم مرتب شهري صافي بعد اقتطاع المستحق هنا العملية تكون انسيابية ولسنا بحاجة الى اكواد فقط استعلام واحد يقوم بالمهمة . ثانيا لاحظت ان نوع الوظيفة او رقمها يختلف من موظف الى آخر .. الى هنا صحيح ولكن حالاات الموظف تختلف فمسمى الوظيفة يجب ان يكون ثابتا ولا يتغير الا في حال الترقية .. وغالبا مسمى الوظيفة يرتبط فقط في المرتب الاساسي والعلاوات وانت جعلت الوظيفة حالاات يجب ان تكون الحالة في حقل منفصل لا دخل للوظيفة بها مثلا مدير توفي يبقى المسمى مدير ولكن الحالة متوفى وهنا تطبق المزايا والضوابط على الحالة وليس على مسمى الوظيفة ظهر لي هذا الخلل عندما غيرت الرقم في Nr من 1 الى 15 تحولت جميع السجلات الى 15 وهذا ايضا خطأ لأن الواجب ان ما سبق تسديده وقت حياته لا يتغير

شكرا استاذي العزيز

وعليكم السلام ورحمة الله وبركاته جرب هذا تسلسل ملئ بيانات الفورم1.xlsm

تفضل جرب اخي ووافينا بالنتيجة Sub RefreshData() ' تعديل Dim i As Long, k As Long Dim last_Dest As Long, lastrow As Long Dim ws_data As Worksheet: Set ws_data = Worksheets("data") For Each ws_dest In ThisWorkbook.Worksheets lastrow = ws_data.Cells(ws_data.Rows.Count, 1).End(xlUp).row last_Dest = ws_dest.Cells(ws_dest.Rows.Count, 1).End(xlUp).row Application.ScreenUpdating = False For i = 2 To lastrow For k = 2 To last_Dest 'في حالة وجود اوراق اخرى على المصنف قم باظافتها هنا If ws_dest.Name <> ws_data.Name And ws_dest.Name <> "اليومية" And ws_dest.Name <> "ورقة6" Then ' شرط تطابق عمود التسلسل وعمود التوجيه If ws_dest.Cells(k, 1).Value = ws_data.Cells(i, 1).Value And _ ws_dest.Cells(k, 2).Value = ws_data.Cells(i, 2).Value Then _ 'في حالة تحقق الشرط ws_dest.Cells(k, 3).Value = ws_data.Cells(i, 3).Value 'التاريخ ws_dest.Cells(k, 4).Value = ws_data.Cells(i, 4).Value ' البيان ws_dest.Cells(k, 5).Value = ws_data.Cells(i, 5).Value 'مدين ws_dest.Cells(k, 6).Value = ws_data.Cells(i, 6).Value 'دائن ws_dest.Activate 'تسطير تلقائي للبيانات DL = ws_dest.Range("A65500").End(xlUp).row DC = ws_dest.Cells(1, Columns.Count).End(xlToLeft).Column ws_dest.Columns("A:F").Borders.LineStyle = xlNone ws_dest.Range(Cells(2, 6), Cells(DL, DC)).Borders.Weight = xlThin End If End If Next Next Next ws_dest ws_data.Activate MsgBox "تم التعديل بنجاح", 64 Application.ScreenUpdating = True End Sub Sub transfer_data() ' ترحيل Dim Sh As Worksheet Dim ws_data As Worksheet: Set ws_data = Worksheets("data") For Each Sh In ThisWorkbook.Worksheets For R = 2 To [B20000].End(xlUp).row If Cells(R, 2).Value = Sh.Name And Cells(R, 2).Value <> Empty Then Application.ScreenUpdating = False Cells(R, 2).Resize(1, 5).Copy Sh.Range("B" & Sh.[B20000].End(xlUp).row + 1) End If Next Next For Each Sh In Worksheets 'في حالة وجود اوراق اخرى على المصنف قم باظافتها هنا If Sh.Name <> "اليومية" And Sh.Name <> "data" And Sh.Name <> "ورقة6" Then Sh.Activate Sh.Range("A3:A1000").ClearContents Sh.Range("A3") = 1 Sh.Range("A3:A" & Range("B" & Rows.Count).End(xlUp).row).DataSeries , xlDataSeriesLinear DL = Sh.Range("A20000").End(xlUp).row DC = Sh.Cells(1, Columns.Count).End(xlToLeft).Column Sh.Columns("A:F").Borders.LineStyle = xlNone Sh.Range(Cells(2, 6), Cells(DL, DC)).Borders.Weight = xlThin End If Next MsgBox ("تم بحمد الله ترحيل القيود لا تنسى أن تشكر الله علي هذه النعم "), vbOKOnly + vbInformation, "لاتنسونا من صالح الدعاء لنا ولولدينا وللمسلمين" ws_data.Activate Application.ScreenUpdating = True End Sub استدعاء من عدة شيتات- V3.xlsm