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

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

ممكن تستخدم المعادلة دى .. ضعها فى الخلية A5 واسحب المعادلة =HYPERLINK("#" & B5 & "!A1",B5)

احبتي ما زلت اعمل على المثال المشكلة الحاصلة هي بسببين : 1- لوحة المفاتيح والأمر sendkeys .. احيانا وداخل الاجراء تتحول الى off فيختل ترتيب الأوامر وقد عالجت المشكلة باستخدام كود يجعل لوحة المفاتيح بوضع ON خلال تنفيذ الكود 2-ملاحظة غريبة بعد ترقية واتساب لم اكن اشاهدها في النسخة القديمة وهي ظهور مربع حوار اختيار المرفق ولصق رابط الصورة ثم اختيار الصورة ثم اسقاطها في واتساب . كل هذا يحدث آليا امام عيني بواسطة الاوامر المتكررة من sendkeys وهذا مزعج وغير احترافي وقد عالجت المشكلة واستبدلت الأوامر بامر واحد وهو اللصق مباشرة باستخدام Ctrl+V وقد نجحت الفكرة واختصرنا عدة حركات والتي كانت هي السبب المباشر في هذا الخلل طبعا استخدمت وحدتين نمطيتين واحدة للنسخ والاخرى للصق ، ولكني توقفت بسبب جودة الصورة .. حيث تظهر دقة الصورة رديئة وبحثت عن حلول فوجدت الحل الشافي ودقة 100% في طريقة الاستاذ جعفر وهي الاستعانة ببرنامج خارجي مساعد للنسخ ولكني افكر فيمن يريد توزيع برنامجه على نطاق واسع بحيث يلزم من يستخدم البرنامج تحميل برنامج الصور المساعد لذا سأنتظر لعلي اجد حلا لجودة الصورة المنسوخة ، والا سوف ارفعه حسب الطريقتين

السلام عليكم و رحمة الله هو نفس الكود بدون اى تغيير و لكن يتم و ضعه فى حدث الملف ThisWorkBook هكذا Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) If Target.Cells.Count > 1 Then Exit Sub Application.ScreenUpdating = False ' اجعل جميع خلايا ورقة العمل الحالية بدون لون Cells.Interior.ColorIndex = 0 With Target ' لون كامل سطر الخلية الفعالة .EntireRow.Interior.ColorIndex = 8 ' لون كامل عمود الخلية الفعالة .EntireColumn.Interior.ColorIndex = 8 End With Application.ScreenUpdating = True End Sub

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

تفضل أخي . اذا كان هذا طلبك اضغط على أفضل اجابة . تفضل المرفق . تكرار الصنف-1.accdb

وعليكم السلام معادله مقدار الدرجات =IF(F4="","",VLOOKUP(F4,'بيانات المعلمين'!$A$2:$K$212,10,0)) =IF(F5="","",VLOOKUP(F5,'بيانات المعلمين'!$A$2:$K$212,10,0)) معادله الملاحظات =IF(F4="","",VLOOKUP(F4,'بيانات المعلمين'!$A$2:$K$212,9,0)) =IF(F5="","",VLOOKUP(F5,'بيانات المعلمين'!$A$2:$K$212,9,0)) تجربة 1.xls

السلام عليكم حالات تثبيت القيم عند سحب المعادلات عندما تكون علامة الدولار في يسار الحرف مثل A$ معناها الخلية مثبتة أفقيا ، اي عند السحب الأفقي لا تتغير القيمة المدخلة في الخلية عندما تكون علامة الدولار في يمين الحرف مثل $A معناها الخلية مثبتة رأسيا، اي عند السحب الرأسي لا تتغير القيمة المدخلة في الخلية عندما تكون علامة الدولار في يسار و يمين الحرف مثل $A$ معناها الخلية مثبتة أفقيا و عموديا ، اي عند السحب الأفقي و العمودي لا تتغير القيمة المدخلة في الخلية

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

تفضل استاذ @محمد احمد لطفى اضغط علي الزر نقل وغير القيمة بالفورم واضغط على الزر مرةً أخرى وكرر ........ انشاء الله طلبك . test2023-1 (5).mdb

اخي محمد جرب الكود التالي في حدث تحت الزر .... Dim a As Integer a = Forms![test1]![NumberEnd] Me("LastNumberx" & a) = Forms![test1]![NumberEnd]

استاذنا @محمد احمد لطفى حليت الطلب بطريقتي أما اذا كنت تطلب الحل بطريقة معينة كما عادتك !!!!!!!!!!!!!! اليك المرفق . test2023-1 (4).mdb

بما انك لم تقم بالاجابة سوف احاول وضع جميع الاحتمالات الواردة بخصوص السؤال الاول يمكنك اختيار ما يناسبك ووضعه في حدث الشيت ''تنبيه عند تكرار نفس القيمة في العمود اكثر من 10 مرات Private Sub Worksheet_Change(ByVal Target As Range) With Target ' تحديد رقم العمود الهدف If (.Column <> 3) Or .Cells.Count > 10 Then Exit Sub ' تحديد اقصى عدد للتكرار المسموح به If WorksheetFunction.CountIf(Columns(.Column), .Value) > 10 Then 'حدف القيمة المدخلة .ClearContents MsgBox "لايمكن طباعة أكثر من 10", vbMsgBoxRight + vbOKOnly, "لا يمكن الاستمرار" End If End With End Sub ''''''''''''''''''''''''''''' Private Sub Worksheet_Change(ByVal Target As Range) ' تنبيه عند تجاوز عدد القيم على العمود 10 قيم Dim ws As Worksheet Set ws = Sheet1 Dim LastRow As Long Application.ScreenUpdating = False LastRow = ws.Range("C65000").End(xlUp).Row DataCount = Application.WorksheetFunction.CountA(ws.Range("C:C")) ' تجديد عدد القيم المسموح بها If DataCount > 10 Then MsgBox "لايمكن طباعة أكثر من 10", vbMsgBoxRight + vbOKOnly, "لا يمكن الاستمرار" 'حدف القيمة المدخلة ws.Cells(Rows.Count, "c").End(xlUp).ClearContents End If End Sub اما بخصوص السؤال الثاني Sub test1() ' تلوين المجموعات في النطاق المطلوب اينما وجد التكرار ' قم بظبط الاعدادات بما يناسبك Const FirstRow As Long = 2 ' اول صف Const FirstColumn As String = "C" 'اول عمود Const LastColumn As String = "F" ' اخر عمود Dim dict As Object Dim Ky As Variant Dim rng As Range Dim Arr As Variant Dim Rl As Long Dim Cols As Variant Dim Idx As Long Dim Sp() As String Dim c As Long Dim R As Long 'أضف العديد من الألوان كما يحلو لك Cols = Array(65535, 10086143, 16763904, 15123099, 9359529, 11854022, 32896, 65280, 16711680, 65535, 16711935, _ 16763904, 13434828, 16764057, _ 13408767, 16751052, 10079487) Application.ScreenUpdating = False Set dict = CreateObject("Scripting.Dictionary") With Worksheets("Sheet1") ' اسم الورقة الخاص بك ' حدف التنسيقات السابقة Columns("C:F").Interior.Pattern = xlNone For c = Columns(FirstColumn).Column To Columns(LastColumn).Column Rl = .Cells(.Rows.Count, c).End(xlUp).Row If Rl >= FirstRow Then Set rng = .Range(.Cells(1, c), .Cells(Rl, c)) Arr = rng.Value For R = FirstRow To Rl If Len(Arr(R, 1)) Then ' تسجيل عنوان كل خلية غير فارغة حسب القيمة dict(Arr(R, 1)) = dict(Arr(R, 1)) & "," & _ Cells(R, c).Address End If Next R End If Next c For Each Ky In dict Sp = Split(dict(Ky), ",") ' شرط عدد التكرار لتنفيد الامر If UBound(Sp) > 1 Then ' تطبيق نفس اللون على نفس القيم For c = 1 To UBound(Sp) .Range(Sp(c)).Interior.Color = Cols(Idx) Next c Idx = Idx + 1 ' إعادة تدوير الألوان إذا كانت غير كافية If Idx > UBound(Cols) Then Idx = LBound(Cols) End If Next Ky End With Application.ScreenUpdating = True End Sub ''''''''''''''''''''''''''''''''''''''''' '("C") تلوين المجموعات بشرط تكرارها في عمود Sub test2() Dim ws As Worksheet Dim cell As Range Dim myrng As Range Dim clr As Long Dim lastCell As Range Set ws = ThisWorkbook.Sheets("Sheet1") 'النطاق الهدف Set myrng = ws.Range("c2:f" & Range("c" & ws.Rows.Count).End(xlUp).Row) ' نطاق الشرط Set myrng2 = ws.Range("c2:c" & Range("c" & ws.Rows.Count).End(xlUp).Row) With myrng Set lastCell = .Cells(.Cells.Count) End With myrng.Interior.ColorIndex = xlNone clr = 3 For Each cell In myrng If Application.WorksheetFunction.CountIf(myrng2, cell) > 1 Then If myrng.Find(what:=cell, lookat:=xlWhole, MatchCase:=False, after:=lastCell).Address = cell.Address Then cell.Interior.ColorIndex = clr clr = clr + 1 Else cell.Interior.ColorIndex = myrng.Find(what:=cell, lookat:=xlWhole, MatchCase:=False, after:=lastCell).Interior.ColorIndex End If End If Next End Sub ولاستخراج القيم وعدد تكرارها يمكنك استخدام الكود التالي Sub test3() ' عدد القيم المكررة Dim rng As Range Dim var As Variant Dim i As Integer Dim ws As Worksheet Set ws = Sheet1 lr = Range("C65536").End(xlUp).Row Set myrng = ws.Range("M1:N" & Range("c" & ws.Rows.Count).End(xlUp).Row) Application.ScreenUpdating = False myrng.clear ws.[M1] = "القيم" ws.[N1] = "عدد التكرار" i = 0 Set d = CreateObject("Scripting.Dictionary") For Each rng In ws.Range("c2:f" & lr) If rng <> "" Then If d.exists(rng.Value) Then d(rng.Value) = d(rng.Value) + 1 Else d.Add rng.Value, 1 End If End If Next For Each var In d.keys '(M) سيتم وضع الاسماء في العمود '(N)وعدد تكرارها في العمود Range("M" & (i + 2)) = var Range("N" & (i + 2)) = d(var) i = i + 1 Next myrng.Borders.Weight = xlThin Range("N2:N" & lr).Font.Color = 255 Set d = Nothing Application.ScreenUpdating = True End Sub واليك الملف عليه جميع الاكواد اختر ما يناسبك بالتوفيق countif_V2.xlsm countif_V3.xlsm

لطفاً أخي @Mohamed abo elmagd هنا منتدى الأكسس . ممكن تطرح سؤالك بمنتدى الإكسل وبتحصل من يساعدك باحتراف .

السلام عليكم راجع الموضوع ادناه لعله يفيد

سلمت يداك أستاذنا الكبير ونفعت الطريقة 100 % كل التقدير والشكر لسيادتكم وجزاكم الله كل الخير .. ولا حرمنا الله من دعمكم المستمر

وعليكم الشلام ورحمه الله وبركاته تم عمل فورم به ليست بجميع اسماء الشيتات التي يحويها الملف مع امكانية البحث وانظر لهذا الموضوع لعله يفيد تم اخذ الفورم والاكواد منه Add Sheets.xlsm

استخدام Google Drive Google Drive هو أسهل طريقة للعمل في مشروع في وقت واحد. يمكن لأي شخص لديه حساب Google الوصول إلى الملفات وتعديلها حسب الحاجة. سجّل الدخول إلى حسابك وانتقل إلى جوجل درايف. بمجرد دخولك ، يمكنك إنشاء ملف جديد أو تحميل ملف موجود. بمجرد إنشاء المستند أو تحميله ، انقر فوق الزر مشاركةفي الجزء العلوي الزاوية اليمنى من ورقة العمل. سيمنحك هذا الخيار لمشاركة جدول البيانات عن طريق إدخال عنوان بريد إلكتروني أو مشاركة رابط مع زملائك. جميع التغييرات يتم تعقبها وحفظها تلقائيًا. يمكنك العمل على المستند معًا في الوقت الفعلي وهو مناسب جدًا.

و عليكم السلام ورحمه الله وبركاته استاذ @Ashraf Ehab رااجع الموضوع ادناه قد يفيدك

تفضل أخي واذا تحب بمثال وافني بالرد . query criteria: Like "*" & Nz(GetMyVar();"*") & "*" Code in a standard moudule: Public MyVar As Variant Public Function GetMyVar() GetMyVar = Myvar End Function code in any form: MyVar = Me.textbox 'run query or open form/report 1- افتح موديول جديد وضع بة Public MyVar As Variant Public Function GetMyVar() GetMyVar = Myvar End Function 2-عند (comboBox) أو (TextBox) المراد أخذ الشرط منه ... بعد التحديث ضع الكود (MyVar = Me.textbox) 3-ضع هذا الشرط الأصفر فقط بدون الأقواس السوداء بالاستعلام ( Like "*" & Nz(GetMyVar();"*") & "*" ) 4- جرب بالشرط خالي وجرب بالشرط ممتلئ واغلق الفورم وشغل الاستعلام . هاك مرفق شغال تمام التمام عندي ... اذا كان هذا طلبك اضغط على أفضل اجابة . تفضل المرفق . حركة القطارات في نمودج.accdb

جرب هذا الموقع للتحويل ملفات pdf

وعليكم السلام ربط خليتين.xlsm

تفضل أخي . 02-1.accdb

الخطوة الاولى نظهر ملفات النظام ويهمنا الجدول MSysObjects نعمل استعلام ونحتاج الى حقلين فقط name وحقل type وفي خانة المعيار نضع الرقم -32768 لتكون جملة الاستعلام تساوي SELECT MSysObjects.Name FROM MSysObjects WHERE (((MSysObjects.Type)=-32768)); ثم نعمل استعلام جديد مصدرة الاستعلام السابق او نحول الاستعلام السابق الى استعلام الحاق وتكون جملة الاستعلام تساوي INSERT INTO tblform ( nameform ) SELECT MSysObjects.Name FROM MSysObjects WHERE (((MSysObjects.Name) Not In (SELECT tblform.nameform FROM tblform;)) AND ((MSysObjects.Type)=-32768)); وهنا تجد اننا استخدمنا معيار جديد عبارة استعلام فرعي لكي يلحق فقط اسماء النماذج الجديدة حتى لا يحصل تكرار لاسماء النماذج التي سبق الحاقها وايضا ممكن الاستغناء عن استعلام الالحاق بالكود وايضا ممكن تحويل الحقل في الجدول الى مربع تحرير وسرد ونجعل مصدرة كود الاستعلام الاول الملف مرفق مثال187.accdb