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

بسم الله الرحمن الرحيم السلام عليكم ورحمه الله وبركاته اساتذتي واخوتى هذا الملف به فهرس لجميع المنتدي ليسهل البحث للاعضاء يوجد فورم يمكنك البحث بها كما يمكنكم استخدام الفلتر العادي وبمجرد الضغط على اي نتيجه من نتائج البحث يتم فتح صفحتها في المنتدي ولا انسي فضل استاذي الكبير ياسر خليل على المساعده في عمل الملف تم تحديث الملف يوم الخميس الموافق 10 - 04 - 2025 فهرس منتدي الاكسيل.xlsb

بسم الله الرحمن الرحيم استخراج القيم الفريده بطريقة العلامه عبد الله باقشير .. حفظه الله ورعاه مع شرح الكود جزى الله كل من ساهم في اخراج هذا العمل الى النور بكل خير Private Sub Worksheet_Activate() 'هذاالكود خاص بالعلامه عبد الله باقشير 'حفظه الله ' الهدف من الكود هو الاتيان بالقيم الفريده 'تم هذا الكود في 23/06/2007 '' '' '' '' '' '' '' '''' '' '' '' '' '' '' '' Application.ScreenUpdating = False 'مسح عمود القيم الفريده [V5:V500].ClearContents 'متغير عمود القيم الفريده Set MyRange = [V5:V500] 'اسم شيت المصدرورقم صف البدايه في شيت المصدر For U = 7 To Sheets("رصد الترم الثانى").[C1500].End(xlUp).Row 'رقم عمودالبيانات الفريده ورقم عمود بيانات المصدر Cells(U, 22) = Sheets("رصد الترم الثانى").Cells(U, 4) 'رقم عمودالبيانات الفريدهفي الشيت الهدف If Application.WorksheetFunction.CountIf(MyRange, Cells(U, 22)) > 1 Then 'رقم عمودالبيانات الفريده Cells(U, 22).ClearContents End If Next 'فرز عمود القيم الفريده [V5:V500].Sort [V5], xlAscending Application.ScreenUpdating = True End Sub استخراج القيم الفريده.rar

انا اضفت هذه الأسطر فقط داخل الحدث

استفسارين : 1- هل كل المزارعين مثل بعض متساوين في نصيبهم من هذه المساحة ؟؟ ام يوجد اختلاف في الحصص ؟؟ 2- في الصورة المرفقة يتضح باقي الأفدنة بالسالب .. هل هذا حقيقي ؟؟ يعني هل يحق للمزارع زراعة مساحات اكبر من نصيبه المقرر ؟؟ التصميم يعتمد على اجابتك الدقيقة

If IsNull(Me.mont) Then msgbox "معلومات غير مكتملة" Exit Sub Else DoCmd.OpenReport "table1", acViewPreview 'لعرض التقرير DoCmd.RunCommand acCmdPrint End If

كل شيء ممكن باذن الله اللي فهمته : عندنا مزارع / منتج / مساحة حاول تشرح الفكرة مفصلا كي تجد المساعدة من اخوانك الاكسس يختلف في التصميم وتنفيذ الفكرة عن اكسل لذا اشرح العملية بإسهاب

عليكم السلام If IsNull(Me.mont) Then msgbox "معلومات غير مكتملة" Exit Sub Else DoCmd.OpenReport "table1", acViewPreview 'لعرض التقرير 'DoCmd.OpenReport "table1", acViewNormal ' طباعة مباشرة End If الشرط.accdb

عليكم السلام اولا اهنيك على ذوقك الرفيع في التصميم طلبك غير واضح .. اشرح ما تريد بشكل مفصل

ربما يكون لدى أستاذتي الحل أنا لا أعرف

تفضل الملف بعد التعديل بدون كود وهذا الكود إذا كنت تحتاج الكود لملف آخر مع تعديل أرقام الصفوف والأعمدة حسب حاجتك Sub t() For i = 1 To 8 Range(Cells(1, 9), Cells(30, 9)).Select Selection.Cut Range(Cells(1, i), Cells(30, i)).Select Selection.Insert shift:=xlToRight Next End Sub عكس اعمدة الجدول مع تجميع خلايا الجدول.xlsx

جريب هذا الكود Sub FasterMacro() Dim wsSource As Worksheet Dim wsCriteria As Worksheet Dim wsExtract As Worksheet Dim sourceRange As Range Dim criteriaRange As Range Dim extractRange As Range ' تحديد ورقة المصدر Set wsSource = ThisWorkbook.Sheets("Sheet1") ' قم بتغيير "Sheet1" إلى اسم ورقتك ' تحديد ورقة المعايير Set wsCriteria = ThisWorkbook.Sheets("ÇáÊÓÌíá (2)") ' قم بتغيير اسم الورقة إذا لزم الأمر ' تحديد ورقة الاستخراج Set wsExtract = ThisWorkbook.Sheets("ÇáÊÓÌíá (2)") ' قم بتغيير اسم الورقة إذا لزم الأمر ' تحديد نطاق البيانات المصدر Set sourceRange = wsSource.Range("AM:BD") ' تحديد نطاق المعايير Set criteriaRange = wsCriteria.Range("'Criteria'") ' تحديد نطاق الاستخراج Set extractRange = wsExtract.Range("'Extract'") ' تطبيق تصفية متقدمة sourceRange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=criteriaRange, CopyToRange:=extractRange, Unique:=False ' تحديد نطاق آخر (يمكن تعديله وفقًا لاحتياجاتك) wsSource.Range("DC3:DT3").Select End Sub

مشاركة مع استاذي الفاضل @ابوخليل هل هذا ماتريد ؟؟؟؟

ما شاء الله بارك الله فيك ا. حسونة

ربنا يبارك لك استاذ حسونه ويبارك لكم جميعا

يمكنك استعمال هذا الكود وتنفيذه في شيت الترحيل وليس في sheet1 Sub mas_taqseem() Application.ScreenUpdating = False lr = Sheet1.Cells(10000, 1).End(xlUp).Row Range("A2:K100").ClearContents col = 1 For i = 2 To lr Step WorksheetFunction.Ceiling((lr - 1) / 3, 1) For j = 2 To WorksheetFunction.Ceiling((lr - 1) / 3, 1) + 1 Cells(j, col) = Sheet1.Cells(j + i - 2, 1) Cells(j, col + 1) = Sheet1.Cells(j + i - 2, 2) Cells(j, col + 2) = Sheet1.Cells(j + i - 2, 3) Next j col = col + 4 Next i Application.ScreenUpdating = True MsgBox "Done by mr-mas.com" End Sub بالتوفيق

مشاركة مع استاذنا وحبيبنا ابو النور تعديل طفيف على الكود من اجل نستغني عن الاستعلامات فقط انسخ الكود الى برنامجك TEST5.rar

اخي الكريم المثال في اصله ثلاث استعلامات وانا اختصرتها في استعلام واحد ( وبه بقية الاستعلامات مخفية ) انظر المثال بعد تفكيكه الى الاستعلامات الموجودة ........ TEST (23).accdb

اتفضل استاذ طبرجل البرنامج بعد التعديل ادراج صورة.accdb

أخي عمر جرب تنزيل هذا التطبيق في هاتفك الأندرويد .. يقوم بنفس العمل 🙂 https://play.google.com/store/apps/details?id=com.poe.android&pli=1

بعد اذان الاستاذ @أبوأحـمـد @ابا اسماعيل لإثراء الموضوع يمكنك الاستفاده

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

أعزائي أعضاء وزوار هذ المنتدى المميز نختم هذا الموضوع كما وعدتكم بالنسخة الاحترافية بأكواد VBA ماذا في هذه النسخة: في كل مرة تفتح البرنامج يحفظ لك صورة من التقويم عن الضغط على أي يوم تظهر لك رسالة معلومات عن اليوم وخيار بإضافة موعد لهذا اليوم في صفحة حول تستطيع التحكم في الصورة التي تظهر عن فتح البرنامج كيف تضع الصورة خلفية لسطح المكتب؟ اضغط على الصورة بزر الفأرة الأيمن اختر تعيين كخلفية لسطح المكتب التقويم الدراسي والمواعيدVBA.xlsm

السلام عليكم ورحمة الله الف شكر للاخ الكريم على المساعدة جزاك الله عنا خيرا ابو ايمان