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

وعليكم السلام ورحمة الله وبركاته يرجى التأكد من المعادلات التي فيها مرجع دائري ، هل تم وضع هذه المعادلات مثلاً وأنت بحاجة هذا المرجع الدائري أم نتيجة خطأ في وضع هذه المعادلات ....بمعنى آخر المرجع الدائري يشمل الخلية التي تريد القيام بمعادلة ما كطرف ... أما إلغاء ظهور التحذير على الرغم من وجود المرجع الدائري كما يلي: من File - Excel Options - Formulas - Enable Iterative Calculation بالعربي: من ملف - خيارات Excel - الصيغ - تمكين الحساب التكراري والسلام عليكم

استبدلت ملفك بآخر تنفيذي سيشتغل الملف ويقوم بتخفيض الأمان عند فتح البرنامج وان اردت التخفيض قبل فتح البرنامج فقط انقر مزدوجا على الملف التنفيذي سيقوم بالمهمة بشكل مخفي لن تشعر به jj2.rar

ما شاء الله تبارك الرحمن ابداعات والله ما لها حدود كل ما يخطر بالبال نجده هنا جعله الله في ميزان حسناتكم وجزاكم الله عنا خير الجزاء

وعليكم السلام ورحمة الله وبركاته لماذا لم تكمل جميلك وترفع الملف؟؟ وتشرح مشكلتك؟ على العموم جرب هذه: Sub insert02() Dim Mj As Worksheet Dim Mn As String Dim Mt As Worksheet Dim last As Integer Set Mj = ThisWorkbook.Sheets("Main") Mn = Mj.Range("L2").Value On Error Resume Next Set Mt = ThisWorkbook.Sheets(Mn) On Error GoTo 0 If Mt Is Nothing Then MsgBox "ورقة العمل '" & Mn & "' غير موجودة. تحقق من الاسم في الخلية L2.", vbExclamation Exit Sub End If last = Mt.Range("B10000").End(xlUp).Row + 1 With Mt .Cells(last, "B").Value = Mj.Range("K5").Value .Cells(last, "C").Value = Mj.Range("K6").Value .Cells(last, "D").Value = Mj.Range("K7").Value .Cells(last, "E").Value = Mj.Range("K8").Value .Cells(last, "F").Value = Mj.Range("K9").Value .Cells(last, "G").Value = Mj.Range("K10").Value .Cells(last, "H").Value = Mj.Range("K11").Value .Cells(last, "I").Value = Mj.Range("K12").Value .Cells(last, "J").Value = Mj.Range("K13").Value .Cells(last, "K").Value = Mj.Range("K14").Value End With Mj.Range("K5:K14").ClearContents End Sub

شكراً استاذ ايهاب والشكر كذالك للاستاذ محمد لقد استفدت من المعلومات .

العفو المعذرة لم أنتبه جيدًا لكلامك وتفضل إليك التعديل selse.xlsm

مرحبا أخي نعم راح يفرغ الجدول لأن الكود يحتوي على تفريغ: Mj.Range("K5:K14").ClearContents لذلك قمت بعمل ملف آخر جديد وكتابة كود آخر جديد يقوم بما تريده بإذن الله بشكل جميل أي ملاحظة أنا حاضر. ادخال البيانات.xlsm هذه أكواد تفريغ شاشة الإدخال: sourceSheet.Range("H4").ClearContents sourceSheet.Range("H6").ClearContents sourceSheet.Range("H7").ClearContents sourceSheet.Range("H8").ClearContents sourceSheet.Range("H9").ClearContents sourceSheet.Range("H10").ClearContents sourceSheet.Range("H11").ClearContents sourceSheet.Range("H13").ClearContents احذف الذي لا تريده وابقي على الذي تريده

جرب هذا المرفق أخي الكريم ,, Foksh.accdb

الف شكر اخي الفاضل ده المطلوب بالظبط شكرا شكرا شكرا هو حضرتك بتشرح بصوت في الشرح ؟ لان مافيش صوت ظاهر عندي للاسف اكيد الشرح هيكون مفيد جدا

تفضل أخي الشرح . واذا كان هذا طلبك اضغط على أفضل اجابة .

ما شاء الله استاذ @Moosak ابداع وتحفة فنيه تسلم ايدك ودماغك 🌷🌷🌷🌷🌷🌷

أستاذنا ومعلمنا الفاضل @Moosak ما شاء الله ، إبداع ، وشرح كافي و وافي . وفقك الله ، وجعله في ميزان حسناتكم .

إخواني الكرام في المنتدى الغالي أقدم لكم اليوم موضوع ليس بالجديد ولكنه جد مفيد (جد .. يعني جداً أوك يا جدو) ..أقصد مفيد جداً الموضوع يتمحور ويتمركز حول معرفة الأرقام المفقودة أو الأرقام الناقصة في سلسلة أرقام .. إليكم الكود الأول المؤدي للغرض (هنا يشترط ترتيب الأرقام) ، مع شرح تفصيلي لأسطر الكود لتتمكن من التعديل عليه Sub MissingNumber_NumbersSorted() 'يقوم الكود بإظهار الأرقام الناقصة في تسلسل معين للأرقام ويشترط ترتيب الأرقام '------------------------------------------------------------------------- Dim SH As Worksheet Dim LR As Long Dim Text As String Dim I As Long, X As Long, XX As Long '[Sheet1] تخصيص المتغير ليساوي ورقة العمل المسماة Set SH = Sheets("Sheet1") 'تحديد آخر صف به بيانات في العمود الأول LR = SH.Cells(SH.Rows.Count, 1).End(xlUp).Row 'حلقة تكرارية بداية من الصف الخامس وحتى آخر صف به بيانات في العمود الأول For I = 5 To LR 'يساوي الفرق بين قيمة الخلية التالية وقيمة الخلية الحالية في الصف المحدد [X] المتغير X = Val(SH.Range("A" & I + 1)) - Val(SH.Range("A" & I)) '[X] استخدام الجملة الشرطية لناتج المتغير Select Case X 'إذا كان الفرق بين قيمة الخليتين أكبر من 1 يتم تنفيذ الحلقة التكرارية ما بين السطرين Case Is > 1 'حلقة تكرارية لتخزين الأرقام الناقصة For XX = 2 To X 'يساوي المتغير نفسه مع قيمة الخلية الحالية مضاف إليها قيمة المتغير في الحلقة التكرارية ناقص واحد ثم سطر جديد[Text]المتغير المسمى 'مثال لفهم هذا السطر '------------------- 'توجد القيمة 50012 [A15] توجد القيمة 50009 وفي الخلية [A14] في الخلية 'بما أن الفرق بين الخليتين يساوي 3 إذاً سيتم تنفيذ الحلقة التكرارية 'بداية الحلقة التكرارية 2 حيث أن رقم 2 هو أول رقم أكبر من واحد ، وفي مثالنا نهاية الحلقة التكرارية تساوي 3 'المتغير المفترض تخزين الأرقام الناقصة فيه عبارة عن سلسلة نصية فيتم إضافة النصوص التي سبق استخراجها ثم إضافة النصوص الجديدة 'الأرقام الناقصة تساوي قيمة الخلية الحالية 50009 في المثال مضافاً إليها قيمة الحلقة التكرارية والتي هنا تساوي 2 في بداية الحلقة التكرارية ليصبح الناتج 50011 ثم ناقص واحد لتحصل على أول رقم ناقص ألا وهو 5010 'يساوي 3 لتحصل في النهاية على الرقم التالي الناقص ألا وهو 5011[XX]مع الانتقال في الحلقة التكرارية يصبح المتغير Text = Text & Val(SH.Range("A" & I)) + XX - 1 & vbCrLf Next End Select Next 'رسالة لإظهار الأرقام الناقصة MsgBox Text, vbMsgBoxRtlReading End Sub وإليكم الكود الثاني وهو أقوى في أنه لا يشترط ترتيب الأرقام Sub MissingNumbers_YK_A() 'يقوم الكود باستخراج الأرقام الناقصة من سلسلة من الأرقام ولا يشترط ترتيب الأرقام '---------------------------------------------------------------------------- Dim InputRange As Range, OutputRange As Range, ValueFound As Range Dim LowerVal As Single, UpperVal As Single, Count_I As Single, Count_J As Single Dim NumRows As Long, NumColumns As Long Dim Horizontal As Boolean On Error GoTo ErrorHandler 'النطاق الذي يحتوي سلسلة الأرقام المراد استخراج الأرقام الناقصة منها Set InputRange = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row) LowerVal = WorksheetFunction.Min(InputRange) UpperVal = WorksheetFunction.Max(InputRange) Horizontal = False 'بداية النطاق الذي سيتم استخراج النتائج به Set OutputRange = Range("E2") NumRows = OutputRange.Rows.Count NumColumns = OutputRange.Columns.Count Application.ScreenUpdating = False If NumRows < NumColumns Then Horizontal = True NumRows = 1 Else NumColumns = 1 End If Count_J = 1 For Count_I = LowerVal To UpperVal Set ValueFound = InputRange.Find(Count_I, LookIn:=xlValues, LookAt:=xlWhole) If ValueFound Is Nothing Then If Horizontal Then OutputRange.Cells(NumRows, Count_J).Value = Count_I Count_J = Count_J + 1 Else OutputRange.Cells(Count_J, NumColumns).Value = Count_I Count_J = Count_J + 1 End If End If Next Count_I Application.ScreenUpdating = True Exit Sub ErrorHandler: End Sub كما تمت إضافة حل بمعادلات الصفيف لتؤدي نفس الغرض وإليكم أيضاً كود رائع للأخ الحبيب سليم حاصبيا مع شرح للأسطر ولا يشترط الترتيب للأرقام أيضاً Sub MissingNumbers_SALIM() 'يقوم الكود باستخراج الأرقام الناقصة في سلسلة أرقام ولا يشترط الترتيب '------------------------------------------------------------------ 'تعريف المتغيرات Dim Dico, D Dim C As Range, Rng As Range Dim B As Long, I As Long Dim MinVal As Double, MaxVal As Double 'النطاق المراد استخراج الأرقام الناقصة منه Set Rng = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row) 'سطر لايجاد أقل قيمة رقمية في النطاق MinVal = Application.WorksheetFunction.Min(Rng) 'سطر لايجاد أكبر قيمة رقمية في النطاق MaxVal = Application.WorksheetFunction.Max(Rng) 'مسح محتويات النطاق الذي سيتم استخراج النتائج به Range("G2", Range("G2").End(xlDown)).ClearContents 'إنشاء متغير من النوع كائن لتخزين الأرقام الناقصة به Set Dico = CreateObject("Scripting.Dictionary") 'حلقة تكرارية لكل الأرقام المسلسلة For I = 1 To (MaxVal - MinVal + 1) 'تعتمد هذه الأسطر على إضافة الرقم الناقص إلى الكائن المخصص لذلك If Application.WorksheetFunction.CountIf(Rng, MinVal + I - 1) = Then If Not Dico.Exists(MinVal + I - 1) Then Dico.Add (MinVal + I - 1), (MinVal + I - 1) End If Next I 'رقم صف البداية للنتائج في العمود السابع B = 2 'حلقة تكرارية لوضع القيم التي تم تخزينها في النطاق المحدد For Each D In Dico.items Range("G" & B) = D B = B + 1 Next D End Sub وعشان عيون أحبابي إليكم الكود الرابع وهو أفضل الأكواد من حيث أنه لا يشترط ترتيب الأرقام وأسطر الكود سهلة الفهم وسهلة التعامل معها Sub MissingNumbers_YK_B() 'يقوم الكود باستخراج الأرقام الناقصة في تسلسل للأرقام ولا يشترط الترتيب '------------------------------------------------------------------- 'تعريف المتغيرات Dim InputRange As Range Dim X As Long, lRow As Long 'تعيين النطاق الذي سيحتوي على سلسلة الأرقام المراد استخراج الأرقام الناقصة منها Set InputRange = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row) 'مسح محتويات النطاق الذي سيتم استخراج النتائج به Range("I2:I1000").ClearContents 'حلقة تكرارية من أقل قيمة بالنطاق لأكبر قيمة بالنطاق For X = WorksheetFunction.Min(InputRange) To WorksheetFunction.Max(InputRange) 'استخدام دالة البحث فإذا كانت القيمة المراد البحث عنها غير موجودة يعطي خطأ 'وبناءً على الخطأ يتم تنفيذ السطر التالي If IsError(Application.Match(X, InputRange, )) Then '[I] الرقم 2 هو رقم صف البداية في العمود '[I] يتم وضع الرقم الناقص في الخلية في الصف المحدد في العمود Cells(lRow + 2, "I") = X 'زيادة المتغير بمقدار واحد للانتقال لصف جديد لإدراج الأرقام الناقصة lRow = lRow + 1 End If Next X End Sub أترككم مع الملف المرفق ...للاستفادة بشكل عملي بالكود كان معكم أخوكم ياسر خليل أبو البراء YK (الموضوع مهدى للأخ الحبيب والأستاذ الكبير أسامة البراوي OB ومهدى للأخ الفاضل نايف - م) حمل الملف من هنا تقبلوا تحياتي

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

استاذنا kkhalifa1960 لا اجد كلمات اعبر لك بها عن تقديرى وشكرى لمجهودك الرائع جزاك الله خيرا وزادك الله من علما نافعا ورزقا طيبا وعملا متقبلا

Sub Test_Meragr_Celle() 'دمج Dim LastRow As Long Dim i As Long Application.ScreenUpdating = False Application.DisplayAlerts = False With ActiveSheet LastRow = .Range("c" & .Rows.Count).End(xlUp).Row For i = LastRow To 2 Step -1 If .Range("c" & i).Value = .Range("c" & i - 1).Value Then Application.Union(.Range("c" & i).MergeArea, .Range("c" & i - 1)).Merge End If Next i End With Application.DisplayAlerts = False Application.ScreenUpdating = True End Sub '********************************* Sub annulation_Meragr_Celle() ' الغاء الدمج Dim Rng As Range, xCell As Range Set WorkRng = Range("c2:c" & Cells(Rows.Count, 3).End(xlUp).Row) Application.ScreenUpdating = False Application.DisplayAlerts = False For Each Rng In WorkRng If Rng.MergeCells Then With Rng.MergeArea .UnMerge .Formula = Rng.Formula End With End If Next Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub اختبار.xlsb

وعليكم السلام ورحمة الله وبركاته تفضل قبل فتح الملف اضغط بزر الفأرة يمين ثم اذهب للخصائص وحط صح على علامة التحذير واضغط موافق ولا تنس تفعيل الماكرو في اعدادات الاكسل حتى يعمل معك الزر وهذا هو الكود المستخدم في الملف: Sub MergeAndCenter() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("Sheet1") Dim lastRow As Long lastRow = ws.Cells(ws.Rows.Count, 3).End(xlUp).Row Dim startRow As Long, endRow As Long startRow = 1 Dim i As Long Application.DisplayAlerts = False For i = 1 To lastRow If i = lastRow Or ws.Cells(i, 3).Value <> ws.Cells(i + 1, 3).Value Then endRow = i If endRow > startRow Then ws.Range(ws.Cells(startRow, 3), ws.Cells(endRow, 3)).Merge ws.Range(ws.Cells(startRow, 3), ws.Cells(endRow, 3)).HorizontalAlignment = xlCenter End If startRow = i + 1 End If Next i Application.DisplayAlerts = True End Sub اختبار1.xlsm

يسلم بؤك مهندسنا الغالي .. 😊🌹 مكتباتنا عااااااااامرة بإبداعاتك .. دي نقطة فبحركم 😅 أتفق معاك تماماً سيدي الفاضل .. 👍🙂 الأصل أن الشخص يتعلم الأساسيات ثم يستخدم الأداة بعدها .. أو يستخدمها ليتعلم منها 😏👌 ومن ضمن الأهداف النبيلة لوجود مثل هذه الأداة تسريع العمل واختصار الوقت حتى مع وجود الخبرة 🙂 وياليتك تيجي تشوف أيش العمايل اللي سواها الذكاء الاصطناعي في المبرمجين !! 😅 ربنا يبارك فيك وحياتك وعلمك أستاذنا المبدع .. 😊🌼 ومنكم نتعلم 🙂

العفو اخي الكريم يسعدنا اننا استطعنا مساعدتك رغم انني اعتقد ان النسخة السابقة افضل لاكن هده اخر محاولة تم تغيير جميع الاكواد من على اليوزرفورم تمت التجربة على اصدار 2016 و 2010 وتمت العملية بنجاح . النسخة المعدلة.xls

لا يوجد وظيفة مباشرة تسمى COUNTIF في Access على حد علمي كما في برامج جداول البيانات الأخرى مثل Excel. ومع ذلك، يمكنك استخدام استعلام SQL لتحقيق نفس الغرض ، وهذا مثال بسيط في الاستعلام SELECT COUNT(*) AS RecordCount FROM MyTable WHERE MyField = 'قيمة_معينة'; وهذا مثال آخر من خلال الـ VBA :- Dim db As DAO.Database Dim rs As DAO.Recordset Dim recordCount As Long Set db = CurrentDb Set rs = db.OpenRecordset("SELECT COUNT(*) AS RecordCount FROM MyTable WHERE MyField = 'قيمة_معينة';") recordCount = rs("RecordCount") rs.Close Set db = Nothing

وعليكم السلام الاستعلام ، ولكن قم بتغيير اسم الجدول واسم الحقل الفارغ: Delete * From tbl_Name Where len([Text_Field] & '')=0 جعفر

اكثر من رائع اخي ياسر وما رأيك بعمل نفس الشيء بواسطة المعادلات ارقام ناقصة.rar