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

هلا اخي جرل المرفق TEST.accdb

تم التعديل Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$B$4" And Target.Count = 1 Then Tranfer_data End If Application.EnableEvents = True End Sub '////////////////////////////////////////////// Sub Tranfer_data() Application.EnableEvents = False Dim R As Worksheet, A As Worksheet, K As Worksheet Dim start_Ro%, i%, m% Dim Start_date As Date, End_date As Date, mot$ Dim x As Boolean, y As Boolean, z As Boolean, t As Byte Dim KRg, Fixrow%, Actrow%, Find_rg As Range, Spec_Rg As Range Dim SF#, SG#, ALLROW% Set R = Sheets("repo"): Set A = Sheets("Achat") Set K = Sheets("Kazina") K.Range("B3").CurrentRegion.Interior.ColorIndex = xlNone Start_date = R.Range("B2"): End_date = R.Range("B3"): mot = R.Range("B4") If R.Range("A8").CurrentRegion.Rows.Count > 1 Then _ R.Range("A8").CurrentRegion.Offset(1). _ Resize(R.Range("A8").CurrentRegion.Rows.Count - 1).Clear i = 5: start_Ro = 9 Do Until A.Range("B" & i) = vbNullString x = A.Range("B" & i) = mot: y = A.Range("D" & i) >= Start_date z = A.Range("D" & i) <= End_date t = Abs(x * y * z) If t Then R.Cells(start_Ro, 1).Resize(, 10).Value = _ A.Cells(i, 2).Resize(, 10).Value start_Ro = start_Ro + 1 End If i = i + 1 Loop i = 5 Set Find_rg = K.Range("B3").CurrentRegion.Columns(3) Set Spec_Rg = Find_rg.Find(mot, lookat:=1) If Not Spec_Rg Is Nothing Then Fixrow = Spec_Rg.Row: Actrow = Fixrow i = 9: m = 9 Do '================================== y = K.Cells(Actrow, "C") >= Start_date z = K.Cells(Actrow, "C") <= End_date t = Abs(y * z) If t Then R.Cells(m, "k") = _ IIf(IsDate(K.Cells(Actrow, "C")), K.Cells(Actrow, "C"), "") R.Cells(m, "k").NumberFormat = "[$-ar-LB] dddd d mmmm yyyy" R.Cells(m, "L") = _ IIf(IsNumeric(K.Cells(Actrow, "G")), K.Cells(Actrow, "G"), "") K.Cells(Actrow, 2).Resize(, 7).Interior.ColorIndex = 40 m = m + 1 End If Set Spec_Rg = Find_rg.FindNext(Spec_Rg) Actrow = Spec_Rg.Row i = i + 1 Loop Until Fixrow = Actrow ALLROW = R.Range("A8").CurrentRegion.Rows.Count + 8 '++++++++++++++++++++++++++++++++++++++++++ R.Cells(ALLROW, "K") = "المجموع" R.Cells(ALLROW, "L") = _ Evaluate("=SUM(L9:L" & ALLROW - 1 & ")") '++++++++++++++++++++++++++++++++++++++++++ End If Set Spec_Rg = R.Range("A8").CurrentRegion If Spec_Rg.Rows.Count = 1 Then GoTo End_Me Set Spec_Rg = Spec_Rg.Offset(1).Resize(Spec_Rg.Rows.Count - 1) Set Spec_Rg = Spec_Rg.SpecialCells(2) With Spec_Rg .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 14 .Font.Bold = True .Interior.ColorIndex = 40 End With End_Me: Application.EnableEvents = True ' '++++++++++++++++++++++++++++++++++++++ End Sub الملف مرفق SAL_My_data_3.xlsm

ومن باب الفائدة ماذا لو اردنا ان نضع تلميح لمربع نص او مربع تحرير وسرد ايضا من خصائص الحقل تنسيق نضع التالي @;"اكتب اسم الموظف" مابين علامات الاقتباس نكتب النص المطلوب ظهورة

تفضل EXEMPLE.xlsm

جرب المرفق TEST -UPDATED.accdb

تفضل Book5.xlsx

يجب تمكين الماكرو وعند اضافة اي مبالغ لاي قسم يجب الضغظ على الزرGETDATA اما كونك تريدها اليا فمعادلة الاستاذ عبد الفتاح كافية جرب الملف وبه معادلة الاستاذ واضف ما تشاء من مبالغ ستظهر اليا برنامج.xlsx

استاذنا سليم حاصبيا والله مشكور جدااا بارك الله فيك احترام من القلب

تم معالجة الامر و عسى ان يكون المطلوب الكود Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$B$4" And Target.Count = 1 Then Tranfer_data End If Application.EnableEvents = True End Sub '////////////////////////////////////////////// Sub Tranfer_data() Application.EnableEvents = False Dim R As Worksheet, A As Worksheet, K As Worksheet Dim start_Ro%, i%, m% Dim Start_date As Date, End_date As Date, mot$ Dim x As Boolean, y As Boolean, z As Boolean, t As Byte Dim arr() Dim KRg, Fixrow%, Actrow%, Find_rg As Range, Spec_Rg As Range Dim SF#, SG#, ALLROW% Set R = Sheets("repo"): Set A = Sheets("Achat") Set K = Sheets("Kazina") K.Range("B3").CurrentRegion.Interior.ColorIndex = xlNone Start_date = R.Range("B2"): End_date = R.Range("B3"): mot = R.Range("B4") arr = Array("الصرف", "الوارد", "الرصيد") If R.Range("A8").CurrentRegion.Rows.Count > 1 Then _ R.Range("A8").CurrentRegion.Offset(1). _ Resize(R.Range("A8").CurrentRegion.Rows.Count - 1).Clear i = 5: start_Ro = 9 Do Until A.Range("B" & i) = vbNullString x = A.Range("B" & i) = mot: y = A.Range("D" & i) >= Start_date z = A.Range("D" & i) <= End_date t = Abs(x * y * z) If t Then R.Cells(start_Ro, 1).Resize(, 10).Value = _ A.Cells(i, 2).Resize(, 10).Value start_Ro = start_Ro + 1 End If i = i + 1 Loop R.Cells(8, "K").Resize(, 3).Value = arr: Erase arr i = 5 Set Find_rg = K.Range("B3").CurrentRegion.Columns(3) Set Spec_Rg = Find_rg.Find(mot, lookat:=1) If Not Spec_Rg Is Nothing Then Fixrow = Spec_Rg.Row: Actrow = Fixrow i = 9: m = 9 Do '================================== y = K.Cells(Actrow, "C") >= Start_date z = K.Cells(Actrow, "C") <= End_date t = Abs(y * z) If t Then R.Cells(m, "k") = _ IIf(IsNumeric(K.Cells(Actrow, "F")), K.Cells(Actrow, "F"), 0) R.Cells(m, "L") = _ IIf(IsNumeric(K.Cells(Actrow, "G")), K.Cells(Actrow, "G"), 0) R.Cells(m, "M") = _ R.Cells(m, "L") - R.Cells(m, "k") K.Cells(Actrow, 2).Resize(, 7).Interior.ColorIndex = 40 m = m + 1 End If Set Spec_Rg = Find_rg.FindNext(Spec_Rg) Actrow = Spec_Rg.Row i = i + 1 Loop Until Fixrow = Actrow ALLROW = R.Range("A8").CurrentRegion.Rows.Count + 8 '++++++++++++++++++++++++++++++++++++++++++ R.Cells(ALLROW, "k").Resize(, 3).Formula = _ "=SUM(K9:K" & ALLROW - 1 & ")" R.Cells(ALLROW, "k").Resize(, 3).Value = _ R.Cells(ALLROW, "k").Resize(, 3).Value '++++++++++++++++++++++++++++++++++++++++++ End If Set Spec_Rg = R.Range("A8").CurrentRegion If Spec_Rg.Rows.Count = 1 Then GoTo End_Me Set Spec_Rg = Spec_Rg.Offset(1).Resize(Spec_Rg.Rows.Count - 1) Set Spec_Rg = Spec_Rg.SpecialCells(2) With Spec_Rg .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 14 .Font.Bold = True .Interior.ColorIndex = 40 End With End_Me: Application.EnableEvents = True ' '++++++++++++++++++++++++++++++++++++++ End Sub الملف مرفق للمرة الثانية SAL_My_data_2.xlsm

أستاذ فتحى ابوالفضل أين الضغط على الإعجاب لهذه الإجابة الممتازة ؟!!!💙

هذا البرنامج يقوم بما طلبت وهو معرب simsetup.rar

الكود المطلوب Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$B$4" And Target.Count = 1 Then Tranfer_data End If Application.EnableEvents = True End Sub Sub Tranfer_data() Dim R As Worksheet, A As Worksheet, K As Worksheet Dim start_Ro%, i% Dim Start_date As Date, End_date As Date, mot$ Dim x As Boolean, y As Boolean, z As Boolean, t As Byte Dim arr() Set R = Sheets("repo"): Set A = Sheets("Achat") Set K = Sheets("Kazina") Start_date = R.Range("B2"): End_date = R.Range("B3"): mot = R.Range("B4") arr = Array("التاريخ", "العميل", "البيان", _ "الوارد", "الصرف", "الرصيد") If R.Range("A8").CurrentRegion.Rows.Count > 1 Then _ R.Range("A8").CurrentRegion.Offset(1). _ Resize(R.Range("a8").CurrentRegion.Rows.Count - 1).ClearContents i = 5: start_Ro = 9 Do Until A.Range("B" & i) = vbNullString x = A.Range("B" & i) = mot: y = A.Range("D" & i) >= Start_date z = A.Range("D" & i) <= End_date t = Abs(x * y * z) If t Then R.Cells(start_Ro, 1).Resize(, 10).Value = _ A.Cells(i, 2).Resize(, 10).Value start_Ro = start_Ro + 1 End If i = i + 1 Loop R.Cells(start_Ro, 1).Resize(, 6).Value = arr i = 5 start_Ro = start_Ro + 1 '++++++++++++++++++++++++++++++++++++++ Do Until K.Range("C" & i) = vbNullString x = K.Range("D" & i) = mot: y = K.Range("C" & i) >= Start_date z = K.Range("C" & i) <= End_date t = Abs(x * y * z) If t Then R.Cells(start_Ro, 1).Resize(, 6).Value = _ K.Cells(i, 3).Resize(, 6).Value start_Ro = start_Ro + 1 End If i = i + 1 Loop '+++++++++++++++++++++++++ End Sub الملف مرفق SAL_My_data.xlsm

ماذا تقصد بملف تنفيذي .. تقصد ملف بامتداد exe. افضل شي هو برنامج ضغط الملفات rar ابحث عن شرح فيديو لتحويل ملف الاكسس الي .exe باستخدام برنامج ضغط الملفات rar تحياتي 🌹

السلام عليكم أولا: أخي أحمد لم تضع مثالا لأقوم بالتعديل عليه أنت وضعت جدولا فقط لقد قمت بإضافة حقل لهذا الجدول اسمه value_web سوف توضع فيه القيمة المستوردة من الويب و أضفت نموذج به نموذج فرعي البرنامج يعتمد على قراءة الكود من النموذج الفرعي لكل سجل ثم يجلب القيمة من الويب و يضعها في الحقل value_web Suppliers-Copy-1.rar

دائما سباق على الخير اخي خالد باركك الرحمن تعالى

من خصائص زر الامر

اخي هذه محاولة مني بالكود عن نفسي افضل الاكواد ديناميكية وسريعة من غير سحب المعادلات اذا زادت البيانات ملاحظة اكتب البيانات في العمود a فقط وسيجلب البيانات الكود Sub tr() Dim lr As Integer Application.ScreenUpdating = False lr = Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To lr Cells(i, 3) = Cells(i, 1) Next Range("c:c").Copy Destination:=Range("E1") Application.ScreenUpdating = True End Sub المصنف1.xlsm

بعد اذن الاساتذة هذ ا كود ديناميكي Sub TransferData() Dim a, b, i&, Dic As Object Set Dic = CreateObject("scripting.dictionary") a = Sheets("Sheet1").[B7].CurrentRegion ReDim b(1 To UBound(a), 1 To 10000) For x = 2 To UBound(a) If Not Dic.exists(a(x, 2)) Then i = i + 1 Dic.Add a(x, 2), i b(1, i) = a(x, 2) End If i = Dic(a(x, 2)) For y = 2 To UBound(b) If IsEmpty(b(y, i)) Then b(y, i) = a(x, 3) Exit For End If Next Next Sheets("Sheet2").[C8].Resize(UBound(b), UBound(b, 2)) = b End Sub POSTING.xls

Classeur1 (2).xlsx

السلام عليكم ورحمة الله ربما تقصد هذا اليك الملف Classeur1.xlsx

أخواني واخواتي أعضاء صرحنا العظيم اوفيسنا **************** وجد ان موضوع مستحقات نهاية الخدمة بالاخص في السعودية يشغل بال الكثيرون من المهتمين بالمجال نظرا لما فيه من حقوق واعباء ففكرت في عمل النموذج حتي لا تضيع الحقوق علي اصحابها نتيجة خطأ في تطبيق قاعدة في قانون العمل او لائحة الشركة راعيت في النموذج قوانين مكتب العمل التي نظمت حقوق العامل عند نهاية العقد او الاستغناء عنه او الاستقالة بحالتها المختلفة 1- اذا كانت فترة العامل اقل من سنتين 2- اذا كانت فترة العامل مابين السنتين والخمس سنوات 3- اذا كانت فترة العامل مابين 5 :10 سنوات 4- اذا كانت فترة العامل اكبر من عشر سنوات وكذلك في الادخال بما يتناسب مع سياسة الشركة اوعقد العامل مثال علي ذلك بدل السكن ( بعض الشركات لاتدخله) ضمن راتب المكافأة وشركات اخري تحسبه بما يقابل راتب شهرين عن سنة واخري تحسبه بما يقابل ثلاثة شهور وكذلك راعيت بدل الاجازة السنوية (30 يوم عن كل سنة لكامل الفترة ) او( 21 يوم للخمس سنوات الاولي ومازاد عنها 30 يوم ) طرق ادخال التاريخ عن طريق الفورم لعدم الاخطاء استخدام التقويم الميلادي او الهجري - ام القري في الحساب تم تخصيص ملاحظات تحت كل حساب يظهر العمليات والقوانين التي اتبعت في الحساب وتناولت الموضوع بفكرة جديدة *********** فورم اخري اسميته الادخال السريع ********************* لضمان عدم الاخطاء في الادخال حيث ان كل مرحلة في الفورم لابد من تعبئتها ليمكنك الانتقال للخطوة التالية الي جانب طباعة النموذج بشكله النهائي الشكل الاخير بعد معالجة المدخلات كالتالي انا جعلت موضوع الفورم جزء من قاعدة شئون الموظفيين الجديدة بشكل جديد ان شاء الله قريبا سوف يتم طرحها لكم وارفقت قوانين العمل حسب مكتب العمل السعودي لتكون مرجع في حالة عدم وجود مرجع ثابت او لائحة منظمة لذلك داخل الشركة ويمكنك الاطلاع علي شروط واحكام الحساب عند ضغطك علي خيار " أحكام حساب المستحقات باسفل الفورم ) كما ان بعض الشركات لاتقوم بابرام عقود للعمال فيكون المرجع الاساسي (قانون مكتب العمل ) أدعوا الله سبحانه وتعالي ان اكون وفقت في عملي هذا (( وَمَا أَسْأَلُكُمْ عَلَيْهِ مِنْ أَجْرٍ إِنْ أَجْرِيَ إِلَّا عَلَى رَبِّ الْعَالَمِينَ )) الشعراء/109. ولكنني اطمع بصالح دعائكم بظهر الغيب مستحقات نهاية الخدمة.rar

بالنسبة لاصدار الويندوز 64 بت اتبع مايلي 1- قم بفك الضغط عن الملف المرفق 2- قم بنقل الملف mscal.ocx للمسار التالي C:\Windows\SysWow64 ثم افتح Run عن طريق الضغط علي شعار الويندوز وحرف R تظهر الشاشة التالية واكتب CMD ثم انتر تظهر الشاشة التالية مع ملاحظة اختلاف مسمي الجهاز عندي عن عندك وبها اكتب مايلي cd \windows\syswow64 ويمكنك نسخه ولصقه مع ملاحظه عند اللصق اضغط كليك يمين واختار لصق تظهر الشاشة التالية اكتب الامر التالي regsvr32 mscal.ocx ثم انتر تظهر الشاشة التالية مع ملاحظة انا لم اقم بالتجربة لان نظامي 32 بت وان شاء الله تضبط معك جرب واعلمني بالنتيجة MSCAL.rar

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