أ / محمد صالح

رائع جدا بارك الله لك

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

ربما تحتاج بعض الأكواد لتعديل لتناسب نسخة 46 بت بإضافة كلمة ptrsafe قبل كلمة function يفضل إرفاق مثال للتوضيح

جميعا بإذن الله بالتوفيق

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

جرب هذه المعادلة في I4 =IF(COUNTIFS(D:D,D4,E:E,E4)<2,H4,C4/SUMIFS(C:C,H:H,H4,D:D,D4)*H4) ومعناها إذا كان عدد تكرار حالات تساوي القراءة السابقة والحالية أقل من 2 يعني مرة واحدة تكون القيمة هي H وغير ذلك تكون كما كانت في المعادلة السابقة

تفضل هذا كود لتغيير اسم قاعدة البيانات الحالية يمكن استعماله بعد الضغط على زر مثلا Public Sub RenameMe(newname As String) Dim dbname As String, ext As String, lockext As String, accesspath As String, scriptpath As String, idx As Integer Const TIMEOUT = 30 scriptpath = Application.CurrentProject.FullName & ".dbrename.bat" accesspath = SysCmd(acSysCmdAccessDir) & "msaccess.exe" For idx = Len(CurrentProject.FullName) To 1 Step -1 If Mid(CurrentProject.FullName, idx, 1) = "." Then Exit For Next idx dbname = Left(CurrentProject.FullName, idx - 1) ext = Mid(CurrentProject.FullName, idx + 1) lockext = IIf(Left(ext, 2) = "ac", "laccdb", "ldb") Dim s As String s = s & "chcp 1256" & vbCrLf s = s & "SETLOCAL ENABLEDELAYEDEXPANSION" & vbCrLf s = s & "SET /a counter=0" & vbCrLf s = s & ":CHECKLOCKFILE" & vbCrLf s = s & "ping 0.0.0.255 -n 1 -w 100 > nul" & vbCrLf s = s & "SET /a counter+=1" & vbCrLf s = s & "IF ""!counter!""==""" & TIMEOUT & """ GOTO CLEANUP" & vbCrLf s = s & "IF EXIST """ & dbname & "." & lockext & """ GOTO CHECKLOCKFILE" & vbCrLf s = s & "ren """ & dbname & "." & ext & """ """ & newname & "." & ext & """" & vbCrLf s = s & """" & accesspath & """ """ & CurrentProject.Path & "\" & newname & "." & ext & """" & vbCrLf s = s & ":CLEANUP" & vbCrLf s = s & "del %0" Dim intFile As Integer intFile = FreeFile() Open scriptpath For Output As #intFile Print #intFile, s Close #intFile s = """" & scriptpath & """" Shell s, vbHide Application.Quit acQuitSaveAll End Sub وطريقة استدعائه RenameMe "mynewname" لاحظ أن الاسم الجديد mynewname بدون الامتداد لأنه يحافظ على نفس امتداد الملف بالتوفيق

جرب هذا الاستعلام Source = "SELECT * FROM Table2 WHERE [fdName4] BETWEEN #" & startdt & "# And #" & stopdt & "#" & IIf([A1] = "" And [A2] = "", "", " And ([fdName4] = " & [A1] & " Or [fdName16] = " & [A2] & ")") & ";"

سواء بالكود أو المعادلة يجب توضيح العلاقة بين ال 30 ماكينة حتى يفيدك أحدنا في مثالك كان هناك 3 علاقات وهي: 1 و 2 لهم نفس المعادلة و3 لها معادلة خاصة و4 و5 لهم نفس معادلة 1 و2 ولا أدري ما إذا كانت العلاقات بين ال 30 كما هي في ال 5 بنفس المتسلسلة أم لا

اعذرني حيث أن المطلوب غير واضح لي لكن حسب فهمي أنك تريد نقل البيانات في الصفوف رقم 4 و 6 و7 و8 وآخر قيمة في الصف الأخير وكلها في العمود الأول من شيت recept وكتابة ok إذا تحقق الشرط والخروج من التكرار إذا تحقق الشرط إن كان فهمي صحيحا فهذا هو التعديل: Sub recp_fill() Application.ScreenUpdating = False For a = 5 To [a10000].End(xlUp).Row If Cells(a, 2) <> "" And Cells(a, 13) = "recept1" Or Cells(a, 13) = "recept2" Or Cells(a, 13) = "recept3" Or Cells(a, 13) = "recept4" Or Cells(a, 13) = "recept5" Or Cells(a, 13) = "recept6" And Cells(a, 14) <> "ok " Then Sheets("po_rec").Cells(a, 14).Value = "ok" With Sheets("recept").[a10000].End(xlUp) .Offset(4- .row, 1) = Cells(a, 2) .Offset(6- .row, 1) = Cells(a, 5) .Offset(7- .row, 1) = Cells(a, 6) .Offset(8- .row, 1) = Cells(a, 7) .offset(0, 1) = Cells(a, 13) End With exit for End If Next a Application.ScreenUpdating = True MsgBox "!تم الترحيل بنجاح", vbInformation + vbMsgBoxRight, "تم الترحيل" Range("b6").Select End Sub بالتوفيق

العمود G والعمود I ضمن المدى الذي إذا تغير يغير المعادلات فتبقى في سلسلة لا نهاية من تنفيذ الكود وحتى تستثني العمود G والعمود I يجب أن تضيف شرط ألا يكون العمود 7 أو 9 If Target.Row > 5 And Target.Column < 11 And Target.Column <> 6 And Target.Column <> 7 And Target.Column <> 9 Then بالتوفيق

ربما لا تحتاج إلى النموذج 1 ولا التايمر الخاص به في حدث عند الفتح للنموذج الرئيس في البرنامج يمكن وضع الكود الموجود في التايمر If Day(Date) = 1 Then DoCmd.OpenForm "frmBackupCompact1" End If وبهذا سيفتح النموذج مرة واحدة عند فتح النموذج الرئيس لأن موضوع التايمر يستهلك ذاكرة الجهاز

ضع هذه المعادلة في الخلية I4 =IF(B4="ماكينة 3",H4,IF(OR(B4="ماكينة 2",B4="ماكينة 5"),C4/(C4+C3)*H4,C4/(C4+C5)*H4)) إن شاء الله تكون هي المطلوب بالتوفيق

أخي الكريم بعض الملاحظات على الكود المعروض من حضرتك: * هذا السطر يقوم بكتابة ok في العمود 14 في كل صف سواء تحقق الشرط أو لم يتحقق لأن هذا السطر بعد نهاية if Sheets("po_rec").Cells(a, 14).Value = "ok" وأعتقد أنه من المفترض أن يتم تنفيذه إذا تحقق الشرط يعني قبل نهاية end if * ثانيا في جملة with يفترض أنك في العمود A وفي آخر صف مكتوب فكيف تنقل القيم في الصفوف السابقة (يفترض أنها مكتوب فيها) لأن ناتج الرقم الأول في offset بالسالب 4 - 21 = -17 ؟؟؟؟ ************ ورغم كل شيء: للخروج من الحلقة التكرارية for يمكنك كتابة exit for قبل سطر نهاية end if ولكن بعد معالجة الملاحظتين السابقتين

يجب أن تعمل استعلامين للنموذجين الفرعيين استعلام لكل نموذج فرعي والاستعلام في الكود هو هذه السطور Set rs = CurrentDb.OpenRecordset("SELECT TTa.asX, TTa.azX, TTB.Bc, TTB.Bd FROM TTa INNER JOIN TTB ON TTa.المعرف = TTB.Ba WHERE TTa.المعرف= " & المعرف & ";", dbOpenSnapshot) With rs .MoveLast .MoveFirst For I = 1 To .RecordCount bc = bc & IIf(bc = "", "", vbCrLf) & Nz(rs.Fields(2).Value, "") bd = bd & IIf(bd = "", "", vbCrLf) & Nz(rs.Fields(3).Value, "") .MoveNext Next I End With Set rs = Nothing طبعا مع تغيير جملة select لما يتناسب مع النموذج الفرعي الجديد

ما أجمل التعاون من أجل قضاء حوائج بعضنا البعض دمتم بخير أحبابي المشاركين وتفضل أخي الكريم هذا هو ملفك حسب الكود السابق لي تم إضافة أمر حفظ الملف باسم هذا الاسم هو رقم المعرف وتاريخ ووقت التصدير وعدم حفظ الملف الأصلي مع إغلاقه ‏‏إرسال الحقول للوورد bookmarks.rar

المطلوب الأخير غير واضح لي بصورة كافية إذا كنت تقصد إغلاق مستند الوورد بعد الكتابة فيه وإغلاق الوورد كله فهذا سهل يمكنك تغيير الإجراء الخاص بالزر إلى ما يلي: Dim X As Object, db As DAO.Database, rs As DAO.Recordset, bc As String, bd As String Set X = CreateObject("Word.Application") X.Documents.Open CurrentProject.Path & "\asdf.docx" X.Visible = True X.ActiveDocument.Bookmarks("asx").Select X.selection.InsertAfter AsX X.ActiveDocument.Bookmarks("azx").Select X.selection.InsertAfter azX Set db = CurrentDb Set rs = db.OpenRecordset("SELECT TTa.asX, TTa.azX, TTB.Bc, TTB.Bd FROM TTa INNER JOIN TTB ON TTa.ÇáãÚÑÝ = TTB.Ba WHERE TTa.ÇáãÚÑÝ= " & ÇáãÚÑÝ & ";", dbOpenSnapshot) With rs .MoveLast .MoveFirst For I = 1 To .RecordCount bc = bc & IIf(bc = "", "", vbCrLf) & Nz(rs.Fields(2).Value, "") bd = bd & IIf(bd = "", "", vbCrLf) & Nz(rs.Fields(3).Value, "") .MoveNext Next I End With Set rs = nothing Set db = nothing X.ActiveDocument.Bookmarks("bc").Select X.selection.InsertAfter bc X.ActiveDocument.Bookmarks("bd").Select X.selection.InsertAfter bd X.ActiveDocument.Close savechanges:=True X.Quit Set X = Nothing MsgBox "done" ما معنى مع ملاحظة أن ملف الوورد سيكون للقراءة فقط؟؟؟؟؟ الملفات التي للقراءة فقط لا يمكن الكتابة فيها سواء يدويا أو بالكود

تفضل أخي الكريم تم إنشاء bookmarks بنفس أسماء الحقول في ملف الوورد تم تعديل اسم الحقل bzX في النموذج كان اسمه bz فقط تم الدمج بين الكودين لكتابة أكثر من سطر بعد العلامة المرجعية بدلالة استعلام ولا تنسوني من دعواتكم الصالحة حيث أنني في أشد الاحتياج إليها هذه الأوقات ‏‏إرسال الحقول للوورد bookmarks.rar

رجاء تحويل المعادلة للصورة العادية أفضل من نمط R1C1 واستعمل هذا الكود تم إضافة شرط العمود لا يساوي 3 Private Sub Worksheet_Change(ByVal Target As Range) If Target.Row > 8 And Target.Column < 8 And Target.Column <> 3 Then Range("c" & Target.Row).Formula = "=a1+b1" Range("h" & Target.Row).Formula = "=IF(ISBLANK(A" & Target.Row & "),0,$B$7*F" & Target.Row & "*(1+G" & Target.Row & "))" Range("i" & Target.Row).Formula = "=IF(ISBLANK(A" & Target.Row & "),0,E" & Target.Row & "*H" & Target.Row & ")" End If End Sub ضع المعادلة مكان =a1+b1 مع استبدال رقم الصف ب Target.Row بالتوفيق

وفقنا الله جميعا لكل خير

يمكن الدمج بين الكودين لذا أعطني الشكل النهائي لملف الوورد بعد التصدير كيف سيكون؟

المشكلة في عدم وجود الدالة OpenClsword وإذا أمكنك تحويل الحقول التي تريد تصديرها إلى استعلام سيكون أسهل في تصديره إلى وورد وهذا ملفك بعد إضافة موديول التصدير إلى وورد إرسال الحقول للوورد.accdb

نفعنا الله جميعا بما علمنا وعلمنا ما ينفعنا وزادنا علما

الأخ الكريم qutubsi الأمر لا يحتاج إلى محاولات فقط تحويل الجداول إلى نطاقات وكما هو مكتوب في التعليمات المترجمة: تقوم بتحديد الجدول الموجود في sheet3 في الخلابا العمودين A & B سيظهر تبويب جديد اسمه تصميم الجدول design احتر تحويل إلى نطاق convert to range ويوجد جدول آخر في نفس الشيت في الخلايا D1:E24 كرر معه نفس الخطوات وستعمل معك المشاركة بإذن الله

تكمن المشكلة في أنك تقوم بعمل سلسلة لا نهائية من استدعاء الكود بحيث أن تقوم بتغيير المعادلة وهذا تغيير يتطلب تغيير المعادلة وهكذا وحل هذه المشكلة في تحديد نطاق التغيير مثلا بعد الصف 8 وقبل العمود 8 وعليه يكون الكود Private Sub Worksheet_Change(ByVal Target As Range) If Target.Row > 8 And Target.Column < 8 Then Range("h" & Target.Row).Formula = "=IF(ISBLANK(A" & Target.Row & "),0,$B$7*F" & Target.Row & "*(1+G" & Target.Row & "))" Range("i" & Target.Row).Formula = "=IF(ISBLANK(A" & Target.Row & "),0,E" & Target.Row & "*H" & Target.Row & ")" End If End Sub بالتوفيق