أ / محمد صالح

الحل في إلغاء تثبيت الخلية F7 ضع هذه المعادلة في الخلية G7 =IF($F7="","",VLOOKUP($F7,$B$4:$C$28,2,0)) ثم اسحب لأسفل كما تشاء

متى يظهر الخطأ؟ عند الضغط على أي زر؟ وفي أي شيت؟

يمكنك استعمال هذا الإجراء وربطه مع أي زر ThisWorkbook.Close 1 بالتوفيق

تم استعمال دوال أخرى في البحث أدق وهي index & match تفضل ملفك بعد التعديل عميل2.xlsx

شكرا لكلماتك الطيبة تم تعديل سطر المعادلة وإضافة شرط أن تكون درجة المعدل أقل من 5 أو يساوي "ن.م.ر" في المشاركة السابقة لي بالتوفيق

المشكلة في هذه الملفات هو اختلاف عدد الأعمدة في الشيتات 10 و11 و12 ولكن تم التغلب عليها بإذن الله يمكنك استعمال هذا الكود لتنفيذ المطلوب Sub insertformula() Application.ScreenUpdating = 0 Dim strfile As String, objBook As Workbook, lr As Long, c As Integer strfile = Dir(ThisWorkbook.Path & "\*.xlsx", vbNormal) While strfile <> "" Set objBook = Workbooks.Open(ThisWorkbook.Path & "\" & strfile) c = objBook.Sheets("data").Range("b10").CurrentRegion.Columns.Count lr = objBook.Sheets("data").Range(IIf(c = 10, "j", "l") & Rows.Count).End(xlUp).Row objBook.Sheets("data").Range(IIf(c = 10, "k", "m") & "12").Formula = "=IF(Or(" & IIf(c = 10, "j", "l") & "12<5," & IIf(c = 10, "j", "l") & "12=""ن.م.ر""),""يكرر"",""ينتقل"")" objBook.Sheets("data").Range(IIf(c = 10, "k", "m") & "12").AutoFill Destination:=objBook.Sheets("data").Range(IIf(c = 10, "k", "m") & "12:" & IIf(c = 10, "k", "m") & lr) objBook.Sheets("data").Range("b12").Select objBook.Close 1 strfile = Dir() Wend Application.ScreenUpdating = 1 MsgBox "Done" End Sub وهو لفتح جميع ملفات الاكسل بامتداد xlsx في مجلد البرنامج ثم عد الأعمدة ووضع المعادلة ثم حفظ المصنف وإغلاقه بالتوفيق

لمنع تعديل الصور في نافذة حماية الشيت protect sheet قم بإلغاء تنشيط edit objects

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

الملف يعمل بصورة طبيعية وهذا رابط للملف على جوجل شيت

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

ربما تقصد تثبيت الصفوف * يمكنك نقل هذه الخلايا جنب بعضها في الصف الأول * ثم من تبويب view / عرض اختر freeze panes / تجميد الألواح ثم اختر freeze top row تجميد صف المقدمة أرجو أن يكون هو المطلوب

جميعا بإذن الله تعالى

تفضل هذا الملف بعد تعديل بسيط تم حذف عمود الكمية الكلية وتمت قراءة البيانات من شيت البيانات الثابتة Test3.xls

بالنسبة لموضوع إنشاء أكثر من صفحة فلا يمكن مع استعمال العلامات المرجعية bookmarks ولكن يمكننا التحايل على الأمر بدمج الملفات التي يتم إنشاؤها بالكود في ملف واحد باسم المجموعة ويتم تخزينه في مجلد باسم (المجموعات) يجب إنشاؤه في نفس مجلد البرنامج وهذا هو الكود بعد التعديل Private Sub أمر11_Click() Dim X As Object Dim objWord As Object Set X = CreateObject("Word.Application") While Me.CurrentRecord < Me.Recordset.RecordCount If Me.Groupx = Me.grooup Then X.Documents.Open CurrentProject.Path & "\asdf.docx" X.Visible = True X.ActiveDocument.Bookmarks("asx").Select X.Selection.InsertAfter NewNamee Dim rs As DAO.Recordset, NewName As String, noobBB As String, NewNamex As String Set rs = CurrentDb.OpenRecordset("SELECT WAdecisA.NewNamee, WBRation.NewName FROM WAdecisA INNER JOIN WBRation ON WAdecisA.noa = WBRation.noob WHERE WAdecisA.noa= " & noa & ";", dbOpenSnapshot) With rs .MoveLast .MoveFirst For i = 1 To .RecordCount NewName = NewName & IIf(NewName = "", "", vbCrLf) & Nz(rs.Fields(1).Value, "") .MoveNext Next i End With X.ActiveDocument.Bookmarks("bc").Select X.Selection.InsertAfter NewName NewName = "" Set rs = CurrentDb.OpenRecordset("SELECT WAdecisA.NewNamee, WCdecisQ.noobBB , WCdecisQ.NewNamex FROM WAdecisA INNER JOIN WCdecisQ ON WAdecisA.noa = WCdecisQ.nooc WHERE WAdecisA.noa= " & noa & ";", dbOpenSnapshot) With rs .MoveLast .MoveFirst For i = 1 To .RecordCount noobBB = noobBB & IIf(noobBB = "", "", vbCrLf) & Nz(rs.Fields(1).Value, "") NewNamex = NewNamex & IIf(NewNamex = "", "", vbCrLf) & Nz(rs.Fields(2).Value, "") .MoveNext Next i End With X.ActiveDocument.Bookmarks("bzd").Select X.Selection.InsertAfter NewNamex NewNamex = "" X.ActiveDocument.saveas2 CurrentProject.Path & "\" & noa & "_" & Format(Now(), "dd_mm_yyyy_hh_mm_AM/PM") & ".docx" X.ActiveDocument.Close SaveChanges:=0 End If DoCmd.GoToRecord Record:=acNext Wend DoCmd.GoToRecord Record:=acFirst strFile = Dir(CurrentProject.Path & "\*.docx", vbNormal) Set objNewDoc = X.Documents.Add While strFile <> "" And strFile <> "asdf.docx" Set objDoc = X.Documents.Open(FileName:=CurrentProject.Path & "\" & strFile) objDoc.Range.Copy objNewDoc.Activate X.Selection.Paste objDoc.Close SaveChanges:=0 Kill CurrentProject.Path & "\" & strFile strFile = Dir() If strFile <> "" And strFile <> "asdf.docx" Then X.Selection.InsertBreak Type:=1 End If Wend X.ActiveDocument.saveas2 CurrentProject.Path & "\المجموعات\" & grooup & "_" & Format(Now(), "dd_mm_yyyy_hh_mm_AM/PM") & ".docx" X.Quit Set X = Nothing MsgBox "done" End Sub فكرة الكود هي البحث عن جميع الملفات بامتداد docx في نفس المجلد غير asdf.docx ودمجهم بالتوفيق

حسب فهمي للمطلوب يمكنك تجربة هذا الملف Test3.xls

شكرا أخي @أبو إبراهيم الغامديهذا الذي أفعله في برمجة الويب كتابة التنسيق بلغة html ووضع البيانات القادمة من الاستعلامات في أماكنها لكن طريقة العلامات المرجعية bookmarks المقترحة من صاحب السؤال هي التي فرضت علينا التعامل معها لحل مشكلته وإذا سمحت لي فالمشكلة في الكود في المرفق في هذه المشاركة Open Me.Groupx & ".mht" For Output As #1 وتغييره إلى Open CurrentProject.Path & "\" & Me.Groupx & ".doc" For Output As #1 ما أجمل الربط بين مهارات البرمجة في كل مجال

يمكن تغيير الأسماء بأسماء افتراضية مثل محمد1 مع السحب المهم مثال يعمل الناس على المطلوب فيه لتقريب وجهات النظر

يوجد معادلتان في الشيت الأولى تقوم بجمع المبالغ الموجودة في العمود D والثانية تقوم بعد هذه المبالغ وتعملان حتى الصف 1000 ويمكنك زيادة نهاية الصفوف في المعادلة إذا تجاوزت 1000 صف من المبالغ

أخي الكريم يمكنك استعمال الدوال المستعملة في هذه النتائج وتنسيقها لتناسب رغباتك Showing results for 'تفقيط مساحة'. - أوفيسنا (officena.net) أو تعديل ملفك ليتناسب مع الأكواد فكلاهما صواب

يمكنك استعمال هذه الحلقات التكرارية للتأكد من تساوي قيمة العمود a في شهر3 مع العمود a في استعلام ثم تلوين النطاق من a إلى r lr = Sheets("شهر3").Cells(Rows.Count, 1).End(xlUp).Row Debug.Print lr For n = 2 To lr lr2 = Sheets("استعلام").Cells(Rows.Count, 1).End(xlUp).Row Debug.Print lr2 For m = 9 To lr2 If Sheets("شهر3").Range("A" & n) = Sheets("استعلام").Range("A" & m) Then Sheets("شهر3").Range("A" & n & ":R" & n).Interior.Color = 10213316 End If Next m Next n يمكنك وضعها بعد أمر الطباعة بالتوفيق

فكرة السؤال هي نفس فكرة هذا الموضوع والحل بإذن الله تعديل كود الزر 11 إلى: Private Sub أمر11_Click() Dim X As Object Dim objWord As Object Set X = CreateObject("Word.Application") While Me.CurrentRecord < Me.Recordset.RecordCount If Me.Groupx = Me.grooup Then X.Documents.Open CurrentProject.Path & "\asdf.docx" X.Visible = True X.ActiveDocument.Bookmarks("asx").Select X.selection.InsertAfter NewNamee Dim rs As DAO.Recordset, NewName As String, noobBB As String, NewNamex As String Set rs = CurrentDb.OpenRecordset("SELECT WAdecisA.NewNamee, WBRation.NewName FROM WAdecisA INNER JOIN WBRation ON WAdecisA.noa = WBRation.noob WHERE WAdecisA.noa= " & noa & ";", dbOpenSnapshot) With rs .MoveLast .MoveFirst For i = 1 To .RecordCount NewName = NewName & IIf(NewName = "", "", vbCrLf) & Nz(rs.Fields(1).Value, "") .MoveNext Next i End With X.ActiveDocument.Bookmarks("bc").Select X.selection.InsertAfter NewName NewName = "" Set rs = CurrentDb.OpenRecordset("SELECT WAdecisA.NewNamee, WCdecisQ.noobBB , WCdecisQ.NewNamex FROM WAdecisA INNER JOIN WCdecisQ ON WAdecisA.noa = WCdecisQ.nooc WHERE WAdecisA.noa= " & noa & ";", dbOpenSnapshot) With rs .MoveLast .MoveFirst For i = 1 To .RecordCount noobBB = noobBB & IIf(noobBB = "", "", vbCrLf) & Nz(rs.Fields(1).Value, "") NewNamex = NewNamex & IIf(NewNamex = "", "", vbCrLf) & Nz(rs.Fields(2).Value, "") .MoveNext Next i End With X.ActiveDocument.Bookmarks("bzd").Select X.selection.InsertAfter NewNamex NewNamex = "" X.ActiveDocument.saveas2 CurrentProject.Path & "\" & noa & "_" & Format(Now(), "dd_mm_yyyy_hh_mm_AM/PM") & ".docx" X.ActiveDocument.Close savechanges:=0 End If DoCmd.GoToRecord Record:=acNext Wend DoCmd.GoToRecord Record:=acFirst X.Quit Set X = Nothing MsgBox "done" End Sub لاحظ أمر حفظ الملف باسم جديد هو رقم القرار وتاريخ ووقت التصدير وتفريغ المتغيرات التي تحتوي على سجلا النموذج الفرعي شرط اختبار المجموعة في السجل الحالي وأنصح بوضع كلمة الأولى مثلا كقيمة افتراضية default value للقائمة الخاصة بالمجموعات بالتوفيق

الشكر لله بالتوفيق

ربما يكون هذا هو السبب في عدم عمل كود الطباعة كود الطباعة يعتمد على أنه بمجرد تغيير قيمة الخلية v7 يتم جلب البيانات الخاصة بالشهادة وبعدها يعطي أمر طباعة الحالية وللدمج بين الكودين يمكنك اتباع الآتي: * جعل الخلية المرتبطة في spinner1 هي الخلية v7 وليست v1 * تغيير v1 إلى v7 في هذين السطرين في كود الإجراء Shehada x = (Ws.Range("V7") - 1) * 2 + 1 y = Ws.Range("V7") * 2 تغيير كود إجراء طباعة الكل إلى ما يلي: Sub printall() ActiveSheet.Select Range("w7") = Range("w7") / 2 For i = Range("v7") To Range("w7") Range("v7") = i Shehada If i <= Range("v7") Then ActiveWindow.SelectedSheets.PrintOut , Copies:=1, preview:=False, Collate:=True End If Next i ActiveSheet.Select End Sub لطباعة الشهادات من 1 إلى 8 نكتب بصورة طبيعية 1 في الخلية v7 ونكتب 8 في الخلية w7 سيحولها الكود من 1 الى 4 لأن في كل صفحة شهادتين بالتوفيق

يسأل عنها صاحب الكود ولكن ربما تكون هذه الطريقة Unviewable+ Best Way for VBA Code Protection — TheSpreadsheetGuru

لماذا لا يمكن وضع كل الجداول في شيت واحد؟ هل يزيد عدد الصفوف فيها جميعا عن 1048576 (مليون و48 ألف و 576) وهو عدد الصفوف المسموح به في اكسل؟ عموما أخي الكريم الترحيل الذي يتبعه التحديث عند التعديل الأفضل فيه أن يكون معادلات