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

وعليكم السلام اختي تفضلي: . . جعفر

جازاك الله الف خير اخي شفان هو المطلوب بالضبط شكرا لك مرة اخرى وتحياتي لك

اتفضل استاذ اليك هذا الاستعلام SELECT tbData.ID, tbData.SALAIRE, DSum("[Janvier]","tbMois","[Data_id]=" & [ID])+DSum("[Février]","tbMois","[Data_id]=" & [ID])+DSum("[mars]","tbMois","[Data_id]=" & [ID])+DSum("[avril]","tbMois","[Data_id]=" & [ID])+DSum("[mai]","tbMois","[Data_id]=" & [ID])+DSum("[Juin]","tbMois","[Data_id]=" & [ID])+DSum("[Juillet]","tbMois","[Data_id]=" & [ID])+DSum("[Août]","tbMois","[Data_id]=" & [ID])+DSum("[Septembre]","tbMois","[Data_id]=" & [ID])+DSum("[Octobre]","tbMois","[Data_id]=" & [ID])+DSum("[Novembre]","tbMois","[Data_id]=" & [ID])+DSum("[Décembre]","tbMois","[Data_id]=" & [ID]) AS Total_Jour, ([SALAIRE]/30)*[Total_Jour] AS Debiteur, DSum("[Montant]","tbDch","[Data_id]=" & [ID]) AS Creancier, [Creancier]-[Debiteur] AS [Rest Apye] FROM (tbData INNER JOIN tbDch ON tbData.ID = tbDch.Data_id) INNER JOIN tbMois ON tbData.ID = tbMois.Data_id GROUP BY tbData.ID, tbData.SALAIRE; ملفك بعد اضافة الاستعلام Database.rar

اتفضل اليك هذا On Error Resume Next Me.RecordSource = "" Me.البحث_العام.SourceObject = "" Dim sql As String Dim sql1 As String 'sql = "ALTER TABLE السجل ALTER COLUMN التسلسل COUNTER PRIMARY KEY" ' تحديد حقل کمفتاح اساسي 'sql = "ALTER TABLE السجل ADD id INT AUTO_INCREMENT;" ' اضافة حقل نمبر sql = "ALTER TABLE السجل DROP COLUMN التسلسل" sql1 = "Alter TABLE السجل ADD التسلسل AUTOINCREMENT(1)" DoCmd.RunSQL (sql) DoCmd.RunSQL (sql1) Me.RecordSource = "السجل" Me.البحث_العام.SourceObject = "البحث العام" سيحذف الحقل التسلسلي ويعمل حقل جديد بارقام جديدة تصفير الارقام التسلسلية.rar

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

تعديل بسيط Option Explicit Sub doyoun() 'استعمال With و End With يزيد من سرعة الماكرو للبيانات الكبيرة 'ْxلا حاجة للمتغير Dim ws As Worksheet, lr%, xx As Worksheet, rng As Range Application.ScreenUpdating = False For Each xx In Sheets With xx lr = .Cells(Rows.Count, "d").End(xlUp).Row '================================== '' For x = 9 To lr لا حاجة لهذا السطر '================================== If .Name <> "الرئيسية" And .Name <> "طباعة" Then .Range("h3:h4").ClearContents Set rng = .Range("d9:d" & lr) .Range("h3").Value = Application.Sum(rng) .Range("h3").Offset(1) = .Range("d" & lr) End If '================================== ' Next لا حاجة لهذا السطر '================================== End With Next Application.ScreenUpdating = True End Sub ان استعمال المتغير x من 9 الى lr هنا تجعل الكود يكرر نقسه عدة مرات في كل صفجة

وعليكم السلام تم اضافة الشرطين للكود دوائر حمراء.rar

حاول وضع عملبة الجمع في الكود وارفعه (الكود فقط) مع مراعاة الملاحظات التي ارسلتها

لا يأس كخطوة أولى لكن لدي 3 ملاحظات 1- تعريف المنغيرات بهذا الشكل Dim ws As Worksheet, x, lr, xx يثقل الملف لان اكسل يعتبر ان Ws هو المتغير الوحيد كصفحة عمل و كل الباقي x,lr,xx يعتبرها Variant وبالتالي يحجز لها مكاناَ كبيراً في Memory بجب ان يعّرف كل متفير بنوعه %ْx هي نفسها X as integer و بذلك تكون البداية Dim ws As Worksheet, x%, lr%, xx As Worksheet 2- لا حاجة لتنشيط الخلية المعنية بالأمر Cells(x, 4).Activate لان هذا يزيد من مهمة الكود دون سبب و لا داعي له فقط اكنب For x = 9 To lr '===================== If xx.Name <> "الرئيسية" And xx.Name <> "طباعة" Then xx.Range("h4").Value = xx.Range("d" & lr) End If '===================== 3-أين عملية الجمع من الرقم 9 الى الخلية ما قبل الاخيرة

وعليكم السلام انا عملت حسب طلبك ، ولكن الظاهر كان في اشياء اخرى انت لم تخبرنا عنها ، وانا لم انتبه لها 1. احذف زر الحفظ ، لأن النموذج الرئيسي يأخذ بياناته من الجدول ، 2. استعمل الكود التالي بدلا عن السابق Dim rst As DAO.Recordset Set rst = Me.Parent.RecordsetClone rst.FindFirst "[التسلسل]=" & Me.التسلسل Me.Parent.Bookmark = rst.Bookmark 'او Me.Parent.RecordsetClone.FindFirst "[التسلسل]=" & Me.التسلسل Me.Parent.Bookmark = Me.Parent.RecordsetClone.Bookmark 3. التعديل يتم حفظه مباشرة في الجدول ، وبدون زر الحفظ جعفر

وعليكم السلام واهلا وسهلا بك في المنتدى تفضل: Account_Pending_Days: IIf(Len([Payment_Date] & '')=0;Time()-[Account_Receiving_Date];[Account_Receiving_Date]-[Payment_Date]) ولكني اعتقد بانه يجب عليك استخدام Date() بدلا عن Time() ليصبح الكود Account_Pending_Days: IIf(Len([Payment_Date] & '')=0;Date()-[Account_Receiving_Date];[Account_Receiving_Date]-[Payment_Date]) جعفر

السلام عليكم ورحمة الله إذا كنت تريد أن توضع الدوائر في شيت "شهادات آخر العام" عند علامات "درجات الفصل الثاني" و "درجة الطالب" فما عليك إلا أن تقوم بتغيير في كود Circles2 في موديول Module6 بتبديل الصف : Set MyRng = Range("F20:M20,F32:M32,F44:M44,F56:M56") بالصف Set MyRng = Range("F20:M21,F32:M33,F44:M45,F56:M57") مع حذف كود Circles1 من موديول10 الذي أضفته حتى لا يختلط مع كود Circles1 الموجود في موديول6 المرتبط بزر "إضافة الدوائر/حذف الدوائر" في شيت "شيت".... بن علية حاجي

بسم الله والصلاة والسلام على رسول الله وعلى آله وصحبه ومن والاه أما بعد: إدارة المنتدى والقائمين عليه وخبراء إكسيل الكرام ...السلام عليكم ورحمة الله وبركاته أعرض لمقامكم الكريم طلباً - ليس لي فحسب - بل يعود بالفائدة على الكثير من روّاد منتداكم الكريم حيث قام كل من الأخوين الصقر "حسام عيسى " و الأخ "أنس الدروبي " جزاهما الله خيراً بالعمل على برنامجين رائعين قيمين يستحقان بنظري الوقوف عند كل منهما لما يتصفان بهما من ميزات هامة .....برنامج EMA بنسخته الحديثة التي دأب على تطويرها زمناً ، وبرنامج الصرافة المالية الخاصة الذي عرضه الأخ أنس كهدية رمضانية لرواد المنتدى الكريم. وطلبي من حضراتكم - فضلاً لا أمراً - الاطلاع على البرنامجين وتقييمهما بخبراتكم الواسعة فإن كانا يستحقان التثبيت ضمن المواضيع الدائمة فبها ونعمت وإن لم يكونا كذلك فإنني اكتفي بعرض هذا الطلب إحقاقاً للحق ..وأنتم خير من يعرف مصلحة رواد المنتدى ...كتبت ذلك فقط للتذكير ببرامج هامة عرضت في زحمة مواضيع كثيرة عرضت وتعرض ليس تقليلاً من شأنها ...ولكن "فذكّر"... أرجو أن لا أكون أثقلت عليكم بطلبي هذا ......تقبلوا تحياتي جميعاً... والسلام عليكم ورحمة الله وبركاته. أخوكم أبو يوسف. السلام عليكم إخوتي الكرام لا أدري بسبب ضعف الإنترنت أو بسبب عطل مفتاح الماوس ضغطت عليه وكتب لي أسفل المشاركة انتظر 11 لا أدري ما 11 هذه هل هي 11يوماً أم ساعة أم ثانية اعذروني عن التكرار. والسلام عليكم. يرجى من الإخوة الكرام إدارة المنتدى حذف هذا الموضوع بسبب تكراره دون قصد مني ...بالغ أسفي واعتذاري.

:: أهلابك اخي :: تفضل هل هذا طلبك ؟ اظهار حقل ومجموعة في الرئيسي.rar

السلام عليكم الطريقة الصحيحة للبرمجة: 1. حقل الرقم التلقائي ، هو فهرسة لسرعة جلب بيانات الجدول للبرنامج ، يعني هذا الحقل يجب ان لا يعتمد عليه المبرمج وانما هو للبرنامج (نعم تستطيع استعماله متى ما شئت بالوضع الذي هو عليه) ، 2. حقل التسلسل ، وهو الحقل الذي يعمله البرنامج حسب حاجته فالآن انت خلطت بين الاثنين والحل ان تترك هذا الحقل مثل ماهو ، ولا تهتم بارقامه ، واعمل حقل جديد تعتمد عليه لبرنامجك جعفر

لا اعلم السبب عندك لكن عندي يعمل بكفاءة انظر المرفق taksit.rar

يلزمك هذا الماكرو Option Explicit Sub Salim() Dim Ws As Worksheet, x%, lr%, k%, My_Rg As Range k = Sheets.Count For x = 2 To k - 1 Set Ws = Sheets(x) With Ws lr = .Cells(Rows.Count, "d").End(xlUp).Row Set My_Rg = .Range("d9:d" & lr) With .Range("h3") .Value = Application.Sum(My_Rg) .Offset(1) = Range("d" & lr) End With End With Next End Sub

السلام عليكم ورحمة الله كان الخلل في بعض الأكواد المكررة مثل Circles1 كودين بالتسمية نفسها وبعض الأوامر فيها مختلفة... تم التعديل على الأكواد وحذف المكررات وإضافة كود RemoveCircles2 (وهو نسخة من كود RemoveCircles1 لكن دون رسالة إعلان حذف الدوائر لأجل الطباعة لئلا تعطل عملية الطباعة... بن علية حاجي الصف الثالث الإبتدائي.rar

أخي الكريم خالد جرب الكود التالي عله يفي بالغرض (طبعاً يوضع الكود في المصنف المسمى PickList) ويحفظ بامتداد xlsm ... قم بفتح الملف الأول والملف الجديد الذي قمت بحفظه بامتداد xlsm ونفذ الكود وستظهر النتائج في العمود الثاني في الملف الجديد المسمى PickList.xlsm Sub Test() Dim swb As Workbook Dim twb As Workbook Dim arr1 As Variant Dim arr2 As Variant Dim v As Variant Dim d As Object Dim m As Long Dim n As Long Dim r0 As Long Dim r As Long Dim s As Long Dim c As Long Set swb = Workbooks("SerializePlantStockReport.xlsx") Set twb = ThisWorkbook Set d = CreateObject("Scripting.Dictionary") m = swb.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row arr1 = swb.Sheets(1).Range("C2:E" & m).Value n = twb.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row arr2 = twb.Sheets(1).Range("A2:B" & n).Value For s = 1 To n - 1 v = arr2(s, 1) If d.exists(v) Then r0 = d(v) Else r0 = 0 End If For r = r0 + 1 To m If arr1(r, 1) = v Then arr2(s, 2) = CStr(arr1(r, 3)) d(v) = r Exit For End If Next r Next s twb.Sheets(1).Range("A2:B" & n).Value = arr2 End Sub

ما رأیک ان ترفق نسخة مصغرة من قاعدة بياناتك وسنعمل المطلوب عليه

الحمد لله أن تم المطلوب على خير والحمد لله الذي بنعمته تتم الصالحات .. أين الإعجاب بالمشاركة الصحيحة واختيار أفضل إجابة ليكون مرجع لمن أراد البحث فيما بعد .. :)

أخي الكريم صلاح جرب الكود التالي ويمكن وضعه في حدث فتح المصنف .. أو كما ترغب فيما بعد Sub OpenClosedWBs() Dim wbk As Workbook Dim ws As Worksheet Dim strInput As String Dim i As Long Dim p As Long Dim lr As Long Application.ScreenUpdating = False On Error Resume Next Set ws = ThisWorkbook.Sheets("Sheet1") For i = 2 To ws.Cells(Rows.Count, "H").End(xlUp).Row p = InStrRev(ws.Range("H" & i), "\") + 1 strInput = Mid(ws.Range("H" & i), p) Set wbk = Workbooks(strInput) If wbk Is Nothing Then Set wbk = Workbooks.Open(Filename:=ws.Range("H" & i)) If wbk Is Nothing Then MsgBox ws.Range("H" & i) & " Not Found!", vbCritical Exit Sub End If End If With wbk.Sheets(1) Range("B" & .Cells(Rows.Count, 2).End(xlUp).Row + 1).Activate End With Set wbk = Nothing Next i On Error GoTo 0 Application.ScreenUpdating = True End Sub

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

اتفضل يا اخي هذا المتصفح الصغير بإذن الله هيشتغل مع حضرتك hosamh3.rar وتكون الحروف سليمة

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