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

بارك الله فيك , عمل رائع جزاك الله خير الثواب

أحسنت استاذ ملاك عمل رائع بارك الله فيك

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

شاهد المرفقات Test_1.xls

السلام عليكم اقدم لكم هذه الطريقة التي اتوقع انها جديدة بحيث يتم تلوين نتيجة البحث في الحقول لتمييزها مرفق صور ومرفق قاعدة البيانات أي سؤال او استفسار جاهزين للاجابة عليه ان شاء الله بحث مع الوان.accdb

بعد اذن الاستاذ/ ابو أشرف تلوين اثثاء الكتابة بحث مع الوان.accdb

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

جرب هذا الكود Option Explicit Sub find_min() Dim F As Worksheet, i%, k% Dim lr, arr(1 To 8) Dim m%: m = 1 Dim st$ Set F = Sheets("Feuil2") lr = F.Cells(Rows.Count, "i").End(3).Row If lr < 9 Then Exit Sub F.Cells(9, "AG").Resize(lr).ClearContents For i = 9 To 30 Step 3 arr(m) = i m = m + 1 Next For k = 9 To lr For i = 1 To UBound(arr) If F.Cells(k, arr(i)) = F.Cells(k, "AF") Then st = st & F.Cells(2, arr(i) - 1) & ";" End If Next F.Cells(k, "AG") = Mid(st, 1, Len(st) - 1) st = vbNullString Next Erase arr: Set F = Nothing End Sub الملف مرفق مع زر لنتفذ الكود find_min.xlsm

الشكر لكل الاخوة العاملون بهذا الموقع الرائع على التعاون الدائم

اخي العزيز Ayman Effat لانك لم تضع قيمة بالحقل غير المنظم انت تركته فارغا انا عملت القيمة الافتراضية للحقل Calculate = صفر كل ماعليك هو تغيير القيمة حسب ماتريد وسيتم تحديث الجدولين تحياتي استعلام تحديث.rar اخي العزيز @عبد اللطيف سلوم انا استخدم اكسس 2010 (32 bit) والملف يعمل بصورة طبيعية جدا استعلام تحديث.accdb اخي @Ayman Effat ارفق لنا ملف لغرض التعديل عليه اختصارا للوقت

قسم بالله ملوك الله يرزقكم من واسع فضلة

اخى الفاضل @moopsiop وعليكم السلام اخى خالد لا تستاذن فنحن الذين نستاذنكم بالمشاركم فنتعلم منكم اخى العزيز جزاك الله خيرا مثال اخى اخالد افضل واقصر فالتعديل ضع الكود التالى فى حدث بعد التحديث وغير ما يلزم من اسماء الحقول والجدول الحقل = رقم الهويه الجدول = TABLE1 ID = اسم الحقل فالنموذج وانتبه هنا الاسم ممكن لعلك قد تكون غيرت الاسم بخلاف مصدر التحكم وهذا اذا كان حقل رقم الهويه نوع بياناته رقم Private Sub ID_AfterUpdate() If (DLookup("[رقم الهوية]", "TABLE1", "[رقم الهوية]=[ID]")) Then MsgBox "تنبيه الرقم المدخل " & " ( " & [ID] & " ) " & " عقوا... تم تسجيله مسبقا ُ جرب رقم آخر", vbCritical, "تنبيه" DoCmd.CancelEvent Me.Undo End If End Sub اذا كان نوع بيانات الحقل نصى ضع الكود التالى مع اتباع نفس التعليمات السابقه Private Sub ID_AfterUpdate() If (DLookup("[رقم الهوية]", "TABLE1", "[رقم الهوية]='" & [ID] & "'")) Then MsgBox "تنبيه الرقم المدخل " & " ( " & [ID] & " ) " & " عقوا... تم تسجيله مسبقا ُ جرب رقم آخر", vbCritical, "تنبيه" DoCmd.CancelEvent Me.Undo End If End Sub ان لم تستطع التعديل فارفق مثالك ليتم التعديل عليه اخى الفاضل تقبل تحياتى وتمنياتى لك وللجميع بالتوفيق

السلام عليكم بعد اذن اساتذتنا الكرام عملت لك ملف اتمنى ان يكون المطلوب تحياتي Database1.rar

بارك الله فيك أخي ابو بسمله على ما تفدمه لاخوانك في المنتدى و اتمنى لك الصحة و التوفيق . و بنسبة موضوع الأخ السائل ،على ما فهمت انه يريد فتح نموذج من frm_Search من داخل نماذج متعددة مثل fr1 , frm2 , frm3 ، مثلاً لو فتح نموذج frm_Search من داخل نموذج frm1 و بعد انهاء عمله في نموذج frm_Search و اغلاقه يفتح له نموذج frm1 و هكذا و باختصار عند اغلاق نموذج frm_Search بذهب الى حيث أتى🤤 و المثال : frm.accdb

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

عليكم السلام ورحمة الله وبركاته تم تعديل مادة اللغة العربية في شهادات نصف العام أما بالنسبة للأوائل لم أرى خطأ في الترتيب شاهد المرفق ثانية(1).rar

وعليكم السلام ورحمه الله وبركاته اخى الفاضل فضلا لاامرا ارفق مثال لما تريد ارفق لك مثال عالسريع وعلى قد حالى لما فهمته منك فى حال كانت النماذج منبثق =لا وكذلك شكلى او مشروط = لا frm1 ; frm2 فى حال كانت النماذج منبثق =نعم وكذلك شكلى او مشروط = نعم frm3; frm4 ارجو ان يكون فى ذلك مساعدتك تقبل تحياتى وتمنياتى لك وللجميع بالتوفيق frm.accdb

السلام عليكم عند الطباعة -خصائص الطباعة- تختار "احتواء كل الأعمدة في صفحة واحدة" (مهما كان عرض الأعمدة)... (هوامش اليمين واليسار يمكن تكون 0) بن علية حاجي BOOK2-3.xlsx

أستاذ /عبدالعزيز محمد الكود بالفعل يبحث بمجرد كتابة أول حرف أول يشترط أن يكون في البداية شاهد الصور

عليك السلام ورحمة الله وبركاته يجب أن تكون إعدادات الصفحة نسبة الضبط 100 % وبعد ذلك تنسق الأعمدة كما تشاء وتحديد الخلايا المراد العمل عليها وتضغط كيلك يمين بالماوس وتختر تنسيق ومنها اختر محاذاة ثم احتواء مناسب جرب هذا BOOK3-3.rar

وعليكم السلام عليك فقط بضبط معادلة VLOOKUP فتاريخ الدفعة الأولى 11 وليس 10 , وبناءا عليه يجب عليك مراجعة باقى المعادلات =IF(D12<1,"",VLOOKUP($G$7,ادخال!$A$5:$AX$1005,11,FALSE)) المالية2020.xlsm

بارك الله فيك وزادك الله من فضله

مبارك الترقية عن جدارة واستحقاق واعانك الله ووفقك للمسؤلية الجديدة التى انت جدير بالفعل على تحملها

تفضل طريقة نشر ملفات pdf او word على صفحتك في الفيسبوك

بارك الله فيك استاذ صالح وزادك الله من فضله

وعليكم السلام-وطالما انك لم تقم برفع ملف-فكان عليك استخدام خاصية البحث قبل رفع المشاركة فهناك العديد من الموضوعات التى تخص طلبك ومنها : ربط يوزر فورم بخلية في الشيت اختفاء ملف الاكسل عن عمل كود لاظهار اليوزرفورم

تفضل Sub exit_end() For Each w In Application.Workbooks w.Save Next w Application.Quit End Sub وهذا كود أخر ايضا يلبى طلبك Sub testSave() Application.DisplayAlerts = False ThisWorkbook.Save Application.DisplayAlerts = True Application.Quit End Sub

تفضل هذا هو الكود Sub clear() kk = MsgBox("هل تريد مسح البيانات ؟", vbYesNo) If kk = vbYes Then Range("b11:C300").ClearContents Range("J11:k300").ClearContents End If End Sub برنامج التنسيق تعديل14.xlsm

ملف شهادة مدرسية صالحة للمتوسط أو الثانوي أردت نشرها تعميم للفائدة وهي من إنجازي sadok 2018X2019.xlsm

موضوع مهم جدا طلب مني احد الاشخاص اثناء تصميم برنامج له ان يكون هناك شروط معينة لاستخراج التقرير طبعا 7 شروط في نموذج واحد وبناءا على الشرط يخرج التقرير الشروط هي : السنة الحالية الشهر الحالي الاسبو ع الحالي السنة الماضية الشهر الماضي الاسبوع الماضي حسب تاريخ الحمد لله قمت بمعالجة الامر وتمت العملية بنجاح واحببت مشاركتكم هذا الانجاز مرفق الصور وقاعدة البيانات اظهار صورة صح بعد الادخال.accdb

استبدل السطر حيث يوجد خطأ في الكود بهذه الــ 3 سطور If st <> vbNullString Then F.Cells(k, "AG") = Mid(st, 1, Len(st) - 1) End If

ما رائيك اخى الفاضل امير باختصار الكود الى الكود الرائع لاستاذنا جعفر @jjafferr جزاه الله خيرا هو وجميع اساتذتنا الافاضل الذين تعلمنا ونتعلم منهم كل يوم وفى حدث قبل التحديث Private Sub Itemcode_BeforeUpdate(Cancel As Integer) On Error Resume Next LN = DLookup("[itemCode] & '|' & [NameItem] & '|' & [الوحدة] & '|' & [سعر الشراء] ", "المواد", "[itemCode]='" & [itemCode] & "'") If IsNull(LN) Then MsgBox " كود_الصنف_المدخل غير صحيح", vbCritical, "مراقب حركة الادخالات" DoCmd.CancelEvent Else X = Split(LN, "|") Me.[itemName] = X(1) Me.[الوحدة] = X(2) Me.[سعر الشراء] = X(3) End If End Sub تقبلوا تحياتى وتمنياتى لكم وللجميع بالتوفيق

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

جرب هذا الماكرو Option Explicit Sub test_mamoun() Dim sh1 As Worksheet Dim sh2 As Worksheet Dim lr1, lr2, x Application.ScreenUpdating = False Set sh1 = Sheets("ترحيل مصروفات") Set sh2 = Sheets("مصروفات") For x = 7 To 17 If sh1.Cells(x, "b") = "" Then go to 1 lr2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row + 1 sh2.Range("a" & lr2).Resize(1, 3).Value = sh1.Cells(x, "b").Resize(1, 3).Value sh2.Range("d" & lr2).Value = sh1.Cells(x, "f").Value sh2.Range("f" & lr2).Value = sh1.Cells(x, "o").Value sh2.Range("g" & lr2).Value = sh1.Cells(x, "q").Value sh2.Range("h" & lr2).Value = sh1.Cells(x, "s").Value sh2.Range("i" & lr2).Value = sh1.Cells(x, "v").Value sh2.Range("j" & lr2).Value = sh1.[l2] sh2.Range("k" & lr2).Value = sh1.Cells(x, "y").Value 1:Next Application.ScreenUpdating = True End Sub

تفضل

أنظر هذا المثال لأستاذنا ابو أدم فهو مثال متكامل ورائع ويحقق طلبك ::بالتوفيق::

السلام عليكم بعد اذن استاذنا العزيز عبد اللطيف سلوم اعتقد يمكن ذلك من خلال نقل الكود الى (عند وضع التركيز) بدل بعد التحديث تحياتي

هل من الممكن التلوين يكون اثناء الكتابة بدون الضغط على انتر

جرب هذاه المعادلة =INDEX($B$3:$B$8,MOD(ROWS($A$1:A1),2)+1,)*1

السلام عليكم ورحمة الله تفضل الملف المرفق وفيد ما تريد بمعادلة صفيف... بن علية حاجي Book121.xlsx

وعليكم السلام-يمكنك استخدام وتطويع هذا الكود Sub SplitWorkbook() Dim FileExtStr As String Dim FileFormatNum As Long Dim xWs As Worksheet Dim xWb As Workbook Dim FolderName As String Application.ScreenUpdating = False Set xWb = Application.ThisWorkbook DateString = Format(Now, "yyyy-mm-dd hh-mm-ss") FolderName = xWb.Path & "\" & xWb.Name & " " & DateString MkDir FolderName For Each xWs In xWb.Worksheets xWs.Copy If Val(Application.Version) < 12 Then FileExtStr = ".xls": FileFormatNum = -4143 Else Select Case xWb.FileFormat Case 51: FileExtStr = ".xlsx": FileFormatNum = 51 Case 52: If Application.ActiveWorkbook.HasVBProject Then FileExtStr = ".xlsm": FileFormatNum = 52 Else FileExtStr = ".xlsx": FileFormatNum = 51 End If Case 56: FileExtStr = ".xls": FileFormatNum = 56 Case Else: FileExtStr = ".xlsb": FileFormatNum = 50 End Select End If xFile = FolderName & "\" & Application.ActiveWorkbook.Sheets(1).Name & FileExtStr Application.ActiveWorkbook.SaveAs xFile, FileFormat:=FileFormatNum Application.ActiveWorkbook.Close False Next MsgBox "You can find the files in " & FolderName Application.ScreenUpdating = True End Sub

الملف بالمسار الخاص بك Test_21.xls

كنت قد قلت لك سابقاً ارفع تموذج عما تريد ( 10 - 20 سطراً لا أكثر من 2000 صف) ولا تهدر الوقت بامور لا تجدي نفعاً و الان قد اتضحت الصورة اليك الماكرو المناسب (النتيجة في شيت Salim لانه ربما اردت التعديل بعض الشيء على الماكرو) الماكرو يعمل على كل البيانات مهما زاد عدد الصفوف في العامود الاول Option Explicit Sub Merge_cells() Dim Sh As Worksheet, Sa As Worksheet Dim lr_ShA%, i% Dim my_rg As Range Set Sh = Sheets("sheet1"): Set Sa = Sheets("Salim") Sa.Range("A:A").Clear lr_ShA = Sh.Cells(Rows.Count, 1).End(3).Row Sh.Cells(1, 1).Resize(lr_ShA + 1).Copy Sa.Cells(1, 1).PasteSpecial Application.CutCopyMode = False Sa.Cells(1, 3).Select For i = 1 To lr_ShA Step 2 Sa.Cells(i, 1).Resize(2).Merge Next With Sa.Cells(1, 1).Resize(lr_ShA) .VerticalAlignment = 2 .InsertIndent 1 End With End Sub المثال مرفق tajriba.xlsm

بعد اذن استاذى الكريم سليم تفضل sales.xlsx

وعليكم السلام تفضل 2.xlsm

اهلا بك اخى الكريم فى المنتدى تفضل هذا الملف لعله يفيدك تعبئة الكومبوبوكس بأسماء أوراق العمل Fill ComboBox With Sheets Names .xlsm

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

وعليكم السلام تفضل اخى الكريم دمج رقم مع تاريخ.xlsx

عليك بوضع هذا السطر داخل الكود Application.ScreenUpdating = False

إخوتي الفضلاء التزاما بقواعد المنتدي فضلت إنشاء موضوع جديد لطرح الفكرة ، لعملية البحث و الفلترة عند الكتابة ضمن نموذج مستمر و تمييز نتائج البحث باللون أو خصائص الخط مثل الخط العريض. حيث طرح السؤال و الطلب ضمن مشاركة احد الاخوة في موضوع يتعلق بالبحث ، بالاضافة لطرح هذا الطلب اكثر من مرة في مواضيع مختلفة . حاولت جعل الكودات بسيطة و قابلة للتعديل حسب التطبيقات التي سيستخدم بها منعا لحدوث اشكالات عند النقل و التطبيق . هناك امور لا بد من مراعاتها عند التعامل مع الفكرة و بعضها رئيسي ومهم لا تنجح الامور الا به ، و هي كما يلي : · نص البحث يكتب ضمن مربع النص txtSearch · البحث و الفلترة تتم في نفس النموذج و هو نموذج مستمر و ليس من خلال نموذج فرعي او مربع قائمة · البحث سيتم ضمن ثلاثة حقول من الجدول tblCustomer ، وهي CompanyName و City و Address يمكن زيادتها حسب الحاجة و مستلزمات التطبيق · مربعات النص في النموذج التي تظهر محتويات الحقول هي غير منضمة unbound · مصدر عنصر التحكم control source للحقول يثبت لكل مربع نص ضمن قائمة الخيارات مثلا (=[CompanyName]) · مربعات النص الثلاثة يجب ان يكون تنسيق النص فيها text format هو (Rich Text) ، وهذه نقطة مهمة حتى يقبل مربع النص كود تغيير خصائص أجزاء النص من حيث اللون و الخط العريض . · كود البحث و الفلترة يكون خلف حدث on change – عند التغيير لمربع النص txtSearch · البحث و الفلترة يفترض في فكرتنا ان تتم عند كل حرف ، وبعد انتهاء الفلترة يعود مؤشر النص ليكتب نص ( حرف ) الفلترة الجديد ، فيصبح مربع النص يتعامل من حرف واحد فقط ، وبالتالي سنضطر لاستخدام خاصية SelStart لتحدد نقطة البداية للنص أو موضع نقطة الإدراج لنتمكن من كتابة اكثر من حرف . · بعد التطبيق اعترضتني مشكلة عدم قبول مربع النص للمسافة بين الاحرف spacebar ، نتيجة استخدام خاصية SelStart و بالتالي كان لا بد من إجبار مربع النص على قبول المسافة بين الاحرف ، و تم ذلك و الحمد لله باستخدام كود في حدث on Key up . · ضمن الكود تم تحديد خاصيتين للخط و هما اللون الاحمر و الخط العريض وذلك لتمييز مكانها ضمن نتائج البحث و الفلترة . · كل حرف يتم كتابته في مربع النص txtSearch تتم بموجبه و مباشرة فلترة النتائج ضمن مربعات النص الثلاثة و تمييز الحرف باللون الاحمر العريض. · بعد الفلترة يتم تغيير مصدر عنصر التحكم عبر الكود باسناد القيم لمربعات النص الثلاثة في النموذج محملة بكود تغيير خصائص الخط لكل حرف تمت كتابته في مربع النص txtSearch · بالضغط على مربع النص txtSearch يتم افراغ مربع النص مما كتب به سابقا لبداية بحث جديد ، كما تظهر كافة سجلات الجدول في مربعات نص النموذج. راجيا من الله عز و جل ان يكون التطبيق وافيا و محققا لحاجات الاخوة ، و ان يكون فيه النفع لهم في تطبيقاتهم . و الله من وراء القصد ... NA_Highlight_Search_results_while_typing.accdb