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

Sub Test_Timer() Dim i As Long, k As Long Range("B3").Value = 0 Do Until Range("B3").Value = 4 Range("B3").Value = Range("B3").Value + 1 For i = 5 To 1 Step -1 Application.ScreenUpdating = True Range("E3").Value = i DoEvents For k = 1 To 100000000 Next k Next i Application.Wait Now + TimeValue("00:00:01") Loop End Sub

بامكانك استخدام المعادله ادناه =IF(A2>0,A1,IF(B2>0,B1,IF(C2>0,C1,IF(D2>0,D1,"")))) فضلا انظري للملف واي استفسار خبريني ياسمين.xlsx

من لم يشكر الناس لم يشكر الله جزاكم الله خيرا وأحسن إليكم جميعاً.. آمين تقبلوا تحياتي العطرة.. والسلام عليكم ورحمة الله وبركاته 💐🏵️🌸

استاذ قلب الاسد انت انسان رائع بارك الله لك فى ذريتك وجعله الله فى ميزان حسناتك

سبقني إليها الأستاذ د.كاف يار أثناء اشتغالي بها ما شاء الله عليه 🙂 هذه محاولتي .. جعلتها في دالة واحدة للفصلين ، وأضطررت لإضافة حقل ترقيم تلقائي في كلا الجدولين للتأكد من وجود رقم مميز لكل سجل وعدم اختلاط النتائج .. 🙂 Public Function FinalResult(ID As Long, TblFinal As String) As String Dim x As Integer: x = 0 Dim n As String Dim TR1 As Double Dim TR2 As Double Dim TR3 As Double Dim TR4 As Double Dim TR5 As Double Dim TR6 As Double Dim DB As DAO.Database Dim RS As DAO.Recordset Set DB = CurrentDb Set RS = DB.OpenRecordset("select * from " & TblFinal & " where [AutoNum] = " & ID & " ;") TR1 = RS!TR1 TR2 = RS!TR2 TR3 = RS!TR3 TR4 = RS!TR4 TR5 = RS!TR5 TR6 = RS!TR6 If TR1 < 50 Then x = x + 1 If TR2 < 50 Then x = x + 1 If TR3 < 50 Then x = x + 1 If TR4 < 50 Then x = x + 1 If TR5 < 50 Then x = x + 1 If TR6 < 50 Then x = x + 1 Select Case TblFinal Case "TBL_Final1" If x >= 1 Then n = "دور ثان" Else n = "ناجح" End If FinalResult = n Case "TBL_Final2" If x > 0 And x < 3 Then n = "مكمل" ElseIf x >= 4 Then n = "باقٍ للإعادة" ElseIf n = 0 Then n = "ناجح" End If FinalResult = n End Select RS.Close Set DB = Nothing Set RS = Nothing End Function والنتيجة في العمود الأخير لكلا الاستعلامين .. احتساب النتيجة عن طريق وحدة نمطية.mdb

تفضل هذه المحاولة للحصول على نتيجة الفصل الأول Public Function Semester1(StudintID As Integer) As String Dim AllMwad As Integer, Set1 As Integer, Set2 As Integer 'Set1 = ناجح / Set2= دور ثاني AllMwad = DCount("*", "Q_Final1", "ID=" & StudintID) Set1 = DCount("*", "Q_Final1", "ID=" & StudintID & " And resultt='ناجح'") Set2 = DCount("*", "Q_Final1", "ID=" & StudintID & " And resultt='دور ثان'") If AllMwad = Set1 Then Semester1 = "ناجح" Else Semester1 = "دور ثان" End If Debug.Print Semester1 End Function و للحصول على نتيجة الفصل الثاني Public Function Semester2(StudintID As Integer) As String Dim AllMwad As Integer, Set1 As Integer, Set2 As Integer AllMwad = DCount("*", "Q_Final2", "ID=" & StudintID) Set1 = DCount("*", "Q_Final2", "ID=" & StudintID & " And resultt='ناجح'") Set2 = DCount("*", "Q_Final2", "ID=" & StudintID & " And resultt='راسب'") If AllMwad = 0 Then Semester2 = "لم يختبر" ElseIf AllMwad = Set1 Then Semester2 = "ناجح" ElseIf Set2 < 3 Then Semester2 = "مكمل" ElseIf Set2 > 3 Then Semester2 = "باقٍ للإعادة" End If Debug.Print Semester2 End Function و للاستدعاء كما يلي نتيجة الفصل الأول Call Semester1([ID]) نتيجة الفصل الثاني Call Semester2([ID]) مرفق الملف بعد التعديل Data_Base.zip

راجع المعادلتين في عمود I و عمود J حضرتك عامل ربط عن طريق IF الشرطية لمجهولين

وعليكم السلام اتفضل اخى @samisalim ان شاء الله يكون ما تريد بالتوفيق ‏‏‏‏devicesdb12 -9_00013_1.accdb

Why do you want me to upload a file? Just copy the formula

اشكركم جميعا وكل عام وانتم طيبون

In cell F2 put the formula =IFERROR(INDEX($A$1:$E$1,MATCH(E2,$A$2:$D$2,0)),"NOT SPECIFIC")

بالتوفيق

ممكن ترفق ملف الأكسل أخي نبيل ؟

اول خطا هو عدم اقفال الحلقة الاولى for i = 1 to 5000 ثاني خطا هو اقفال الحلقة الثانية قبل اقفال جملة if التي هي بداخل حلقة for

جزاك الله خيرا استاذ محمد

تفضل أخي الكريم new.xlsm

الف شكر لاستاذنا الغالى Moosak الكود فعال جدا وتم تجربته جزاك الله كل خير

وفيك بارك الله اذن ستقوم بعمل نسخه لكل سنه اذا فضلت على الوضع الحالى فالبرنامج الصوره المرفقه الاخيره من اى مثال هل هى من المثال الاخير الذى ارفقته لك ام لا ان كانت نعم فهل سمح لك النموذج باضافه اكثر من 5 اهداف ام انك ادخلت الاهداف الزياده عن طريق الجدول؟ لانه النموذج لن يسمح لك باضافه اكثر من 5 اهداف للموظف بالنسبه للدرجه قمت باخذها مباشره من الجدول tbl_eval ولم انتبها لها الا الان والصحيح انك سوف تدخلها يدويا بناء على تقييمك للموظف بالنسبه لهذه النقطه ( يفضل ان تظهر الدرجة مباشرة بدل كتابتها) من اين سوف تضع هذه القيم ؟ مرفق المثال بعد تعديل هذه الجزئيه (والصحيح انك سوف تدخلها يدويا بناء على تقييمك للموظف ) بالتوفيق 2_تقييم.mdb

السلام عليكم ورحمة الله وبركاته أختي الكريمة حسب علمي الضحل الجواب ضمن الملف المرفق =ROUND(AB433*21%;2) دالة تقريب الخلية المذكورة*٢١% إلى رقمين عشريين. =ROUND(IF(CB433>500;500;CB433);2) دالة تقريب إذا كانت الخلية أكبر من 500 أعطني 500 وإن لم تكن أعطني قيمة الخلية ذاتها مقربة إلى رقمين عشريين ياسمين محمد.xlsx

ممتاز استاذنا الفاضل بارك الله فيك

بارك الله فيك استاذنا

السلام عليكم أخي الكريم يمكنك استخدام المعادلة التالية، أرجو أن تكون حلاً لاستفسارك =IF(COUNTIF($A$7:A7;A7)=1;SUMIF(MARCH!A7:A44;Data!A7;MARCH!I7:I114);"") تقبل تحياتي العطرة والسلام عليكم new.xlsx

وعليكم السلام ورحمه الله وبركاته مشاركه مع اخى @Moosak جزاه الله كل خير اخى @saffar وقبل المضى قدما على هذا البرنامج هل التقييم مره واحده بالعام ام اكثر من مره اذا كان مره واحده فسوف تحتاج لعمل نسخه لعمل كل عام 👇 اذا كان اكثر من مره خلال العام فيجب مراجعه قاعده البيانات والنظر فيها مره خرى لانك لن تستطيع اضافه اهداف اخرى لاى موظف سبق وان تم اضافه اهداف له وعلى كل قمت لك بالتعديلات المطلوبه بسؤالك بالتوفيق 1_تقييم.mdb

ربما ؟ Sorting test (n)1 (1).xlsm

السلام عليكم تجد ضالتك بإذن الله في الملف المرفق... Ek_4.xlsm

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

سلمت يداك اخى الكريم احترامى

تفضل بعد اذن استاذنا محمد فؤاد Officena1.xlsx

أخي نبيل تم تطبيق نفس المعادلات بالأكسس مع معادلة حساب فترة الخدمة تلقائيا هكذا : والنتيجة 🙂 تأكد من المعادلات أو عدلها إن كانت غير صحيحة 🙂 nabilali.accdb

لو راسل الصورة ذي من الأول .. كان ريحت العالم من زمان 😅 نفس المعادلات ممكن تستخدم في الأكسس .

كلمة مبدع قليلة جدا جدا .. بارك الله في علمك و نفع به العباد فعلا هنا يطلق على هذه الفكرة ابداع لا حدود له و تفكير خارج الصندوق

وعليكم السلام ورحمة الله وبركاته .. أخي @saffar هذه صورة من برنامجك .. إشرح ما تريده من واقع البرنامج .. لأن الناس تتوه لما تدخل وتدور وما تشوف كلمة ( أهداف ) مثلا ، وأنت كاتبنها في السؤال ..!! 🙃 قل مثلا : أريد لما أفتح الفورم ( كذا ) وأضغط على الزر (كذا) يحدد لي ( كذا وكذا ) 🙂 تحياتي 🙂

بصراحة هذا اخر محاولة وساخرج من هذا الموضوع تم اعطائه اكثر من حجمه Sub export_sheets() Dim Fname As String, ws As Worksheet Application.DisplayAlerts = False Sheets(Array("SH1", "SH3")).Copy For Each ws In ActiveWorkbook.Sheets ws.UsedRange = ws.UsedRange.Value Next ws ActiveWorkbook.SaveAs Filename:= _ "C:\Users\PC WORLD\Desktop\" & " report_ " & "W" & Format(Date, "WW") & "_" & Format(Date, "YYYY") & ".xlsx", FileFormat:=51 ActiveWorkbook.Close Application.DisplayAlerts = True End Sub

Put the following line before the line of Next Next Should be If [E13] = 0 Then Exit For ActiveWindow.SelectedSheets.PrintOut Copies:=1 Next

Sub Print6() Dim ws As Worksheet For Each ws In ThisWorkbook.Worksheets If ws.Name = "Sheet1" Or ws.Name = "Sheet2" Or ws.Name = "Sheet3" Then ws.Range("A1:K" & ws.Cells(Rows.Count, "B").End(xlUp).Row).PrintOut End If Next End Sub

اخي عبدالله كللامك مظبوط يوجد خطاء تم تعديله و كان الخطاء في الحلقة الدائرية للتاكد من خلو الخلية الهدف من اي بيانات للكتابه بها سامحنا ... كل ابن آدم خطاء البرنامج.xlsm

من باب الحفاظ على حقوق النشر والملكية الفكرية يجب ذكر واضع الكود للملف الذي قمت برفعه جرب هذا الكود Option Explicit Sub Give_ALL_Data() Dim Arr_sh(), i%, m%: m = 2 Dim Arr_counte() For i = 1 To Sheets.Count - 1 ReDim Preserve Arr_sh(1 To i) ReDim Preserve Arr_counte(1 To i) Arr_sh(i) = Sheets(i).Name Arr_counte(i) = Application.Max(Sheets(i).Range("a:a")) Next Sheets("تجميع").Range("b2:i500").ClearContents For i = LBound(Arr_sh) To UBound(Arr_sh) Sheets("تجميع").Range("b" & m).Resize(Arr_counte(i), 8).Value = _ Sheets(Arr_sh(i)).Range("b2").Resize(Arr_counte(i), 8).Value m = m + Arr_counte(i) + 1 Next Erase Arr_sh: Erase Arr_counte End Sub الملف مرفق Data_from_all_sheets.xlsm

أخي الحبيب محمد تفضل الملف المرفق ...كل ما عليك أن تضع أوراق العمل المطلوب جلب البيانات منها في مصفوفة بالترتيب الذي ترغب التعامل معه Sub CollectDataFromSheets() Dim MyArray As Variant, Item Dim LR As Long MyArray = Array("خط التعبئة والتغليف", "خط الاستلام والتجهيز", "1", "2", "3") Application.ScreenUpdating = False Sheets("شيت مجمع").Range("A3:H1000").ClearContents For Each Item In MyArray With Sheets(Item) .Activate LR = .Cells(300, 2).End(xlUp).Row .Range("B5:H" & LR).Copy With Sheets("شيت مجمع") .Range("B" & .Cells(Rows.Count, 2).End(xlUp).Row + 1).PasteSpecial xlPasteValues .Range("A" & .Cells(Rows.Count, 1).End(xlUp).Row + 1 & ":A" & .Cells(Rows.Count, 2).End(xlUp).Row) = Sheets(Item).Name End With End With Next Item Sheets("شيت مجمع").Activate: Range("A1").Select Application.CutCopyMode = False Application.ScreenUpdating = True End Sub ويتم ذلك من خلال السطر الرابع إليك الملف المرفق للتجربة ولا تنسى أن تحدد المشاركة التي تعجبك كأفضل إجابة ليظهر للأخوة الأعضاء أن الموضوع مجاب ، وعشان آخد نقطة (بعد التعب دا كله) تقبل تحياتي Collect Data From Sheets V2.rar

تفضل أخي الحبيب الملف المرفق.. التجميع سيكون من الشيتات 1 ، 2 ، 3 حسب ما فهمت .. الكود سيعمل مع الشيتات التي سوف تقوم بترقيمها بشرط تغيير طفيف في الكود .. في الحلفة التكرارية بدلا من 1 إلى 3 ، ستقوم بتغيير آخر رقم لآخر شيت تريد Sub CollectDataFromSheets() Dim I As Long, LR As Long Application.ScreenUpdating = False Sheets("شيت مجمع").Range("A3:H1000").ClearContents For I = 1 To 3 With Sheets("" & I & "") .Activate LR = .Cells(300, 2).End(xlUp).Row .Range("B5:H" & LR).Copy With Sheets("شيت مجمع") .Range("B" & .Cells(Rows.Count, 2).End(xlUp).Row + 1).PasteSpecial xlPasteValues .Range("A" & .Cells(Rows.Count, 1).End(xlUp).Row + 1 & ":A" & .Cells(Rows.Count, 2).End(xlUp).Row) = Sheets("" & I & "").Name End With End With Next I Sheets("شيت مجمع").Activate: Range("A1").Select Application.CutCopyMode = False Application.ScreenUpdating = True End Sub تقبل تحياتي Collect Data From Sheets.rar

للأخوة اللى مش واخدين بالهم من الملف الجديد . اعذرونى على اتجاه الكتابه أظن صعب عليه أظبط ده كله الملف الجديد فيه ننقل البيانات من ملف مغلق الى ملف مغلق والملفان كل منهما فى مسار مختلف والنقل تم بكود كما وعدتكم . يمكن تحميله من الميديا فاير على الرابط التالى : http://www.mediafire.com/download/df17y8oe81f1brk/copy__data_from_a_closed_excel_file__&_paste_it_in_a_closed_excel_file_by_mokhtar_(__2_).rar أو تحميله من المرفقات. وتحياتى لكم ومحدش يسيب الموضوع ( لسه فيه باقى ) copy data from a closed excel file & paste it in a closed excel file by mokhtar ( 2 ).rar