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

بما انك لم تقم بالاجابة سوف احاول وضع جميع الاحتمالات الواردة بخصوص السؤال الاول يمكنك اختيار ما يناسبك ووضعه في حدث الشيت ''تنبيه عند تكرار نفس القيمة في العمود اكثر من 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

تفضل أخي . SendKeys"^+{f}",True

تفضل اخي تم تعديل الكود ليشتغل معك تلقائيا عند التغيير في عمود (c) واظافة امكانية اختيار الالوان . يمكنك تعديلها على حسب احتياجاتك . '''تنبيه عند تكرار نفس القيمة في العمود اكثر من 10 مرات Private Sub Worksheet_Change(ByVal Target As Range) Dim ws As Worksheet Dim cell As Range Dim myrng As Range Dim clr As Long Dim lastCell As Range Dim MH As Variant Dim Idx As Long With Target ' تحديد رقم العمود الهدف If (.Column <> 3) Or .Cells.Count > 10 Then Exit Sub On Error Resume Next ' تحديد اقصى عدد للتكرار المسموح به If WorksheetFunction.CountIf(Columns(.Column), .Value) > 10 Then 'حدف القيمة المدخلة .clear MsgBox "لايمكن طباعة أكثر من 10", vbMsgBoxRight + vbOKOnly, "لا يمكن الاستمرار" End If End With 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 'تحديد الالوان MH = Array(RGB(255, 128, 128), RGB(204, 255, 255), RGB(51, 204, 204), RGB(204, 204, 204), _ RGB(153, 204, 0), RGB(255, 102, 0), RGB(255, 128, 128), _ RGB(204, 204, 155), RGB(255, 255, 0), RGB(255, 153, 0), RGB(0, 255, 0), RGB(255, 0, 255)) 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.Color = MH(Idx) Idx = Idx + 1 Else cell.Interior.ColorIndex = myrng.Find(what:=cell, lookat:=xlWhole, MatchCase:=False, after:=lastCell).Interior.ColorIndex End If End If Next ' يمكنك تغعيل السطر التالي في حالة الرغبة في استخراج عدد التكرار 'Call test3 End Sub countif_V5.xlsm

تعمل فولدر وليكن (icons) ثم تعبئ به كل الأيكونات التي تريدها تجيبها من جوجل بامتداد (ico.) أو (.bmp) وبعطيك برنامج يصنع أيكونات فقط افلت أي صورة حتى صورتك . واحفظها بالفولدر الذي أنشأته . ثم تستدعي الأيكون من فورم الأكسس عادي . ولو مش عارف كيف نشرح . المهم تقرأ البرنامج وين طريقة الحفظ . واليك البرنامج ووافني بالرد . ToYcon.rar

تفضل جرب بالتوفيق Ctrl + Shift + f = SendKeys "^+F"

السلام عليكم لدي مربع نص textbox1 وهناك ثلاثة ازرار الاول button1 والثاني button2 والثالث button3 احتاج عند الضغط على الزر الاول يكتب قي مربع النص الرقم الاخير من اسم الزر يمعنى يكتب 1 وهكذا يقية الازرار طبعا نوجد طريفة وهي كتاية الكود التالي تحت كل زر وحسب الرقم المطلوب me.textbox1 = 1 لكني احتاج طريقة اسهل لوجد العديد من الازرار في مشروعي وهناك مجموعة من الاكواد المرتبطة في كل زر New Microsoft Access قاعدة بيانات.accdb

ابشروا وما زلت في محاولة التحسين كنت اظن انني احكمت العمل فوجئت بظهور ثغرات ... يجب ان اغلقها تماما .. يجب ان يكون العمل محكم

تفضل اخي countif_V4.xlsm

بارك الله فيك أخي وربي يجازيك هذا هو المطلوب بالدات

أستاذنا @محمد احمد لطفى طيب مفيش إطراء للعبد لله أو شكراً ................... مالك ناشف ليه ومفيش حل مني لك بيعجبك !!!!!!!!!!!!!!!!!!

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

وعليكم السلام - وكيف تنتظر المساعدة من أحد ومحرر الأكواد محمى بكلمة سر ؟!!! وبما ان محرر الأكواد محمى فيمكنك ذلك من خلال اضافة هذا السطر فى كل كود من أكواد التكست بوكس التى تقوم بإدخال التاريخ بها مع مراعاة تغيير اسم التكست بوكس لما متماشى معك , ولكم جزيل الشكر Me.txtBrewDate = Format(CDate(Me.txtBrewDate), "dd/mm/yyyy")

برفع اذا امكن اليوم تحديث ولكن ازار في مرفق اعلاه في سابق شغاله تصحيح " ' " اضافة داله بسيطه واعذر كل من لم يستطع حله لو هو بسيط مع هديه بروقريس x x x دوران بجهات مختلفه تطوير من مرفق سابق @Moosak وقول واتس آب بتحديث جديد لا يمكن ارفقه مع ثلاث هدايه لا تقول chatGPT خرف!

مع اني ربما لم افهم المطلوب ولكني ساحاول ممكن نعمل اجراء Sub k() Dim a As Byte Dim n, m As String For a = 1 To Len(ActiveControl.Name) n = Mid(ActiveControl.Name, a, 1) Select Case n Case "0" To 9 m = m & n End Select Next a Me.textbox1 = m End Sub ثم في كل زر امر نستدعي الاجراء بالشكل التالي k طبعا هذا الاستداء لايؤثر على اي اوامر في الازار هذا الرد مجرد تحفيز للاساتذة لتقديم حلول افضل الملف في المرفقات New Microsoft Access قاعدة بيانات).accdb

السلام عليكم و رحمة الله استخدم المعادلة التالية بدلا من المعادلة الحالية فى عمود الرقم =IFERROR(INDEX('أسماء الطلاب'!$A$2:$E$890;SMALL(IF('أسماء الطلاب'!$E$2:$E$890=$E$9;ROW('أسماء الطلاب'!$E$2:$E$890));ROW(A1))-1;1);"") و فى عمود الاسم غير الرقم 1 الى الرقم 2 المعادلتين معادلات صفيف اى يجب الضغط على CTRL + SHIFY + ENTER لكى تعمل معك المعادلة

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

تفضل ياأخي والله شغال ويعطي النتيجة بالصورة المرفقة . واليك المرفق بعد ادخل قيم . حسابات-2.rar PhoXo32.bmp

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

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

تفضل أخي @أبو امين 🙂 << تعديل >> عملت لك دالتين .. واحدة للنماذج وأخرى خاصة بالتقارير .. أنسخهم هم الإثنين في موديول : Public Sub ShowOrHideFormControls() Dim Frm As Form Dim Ctl As Control Set Frm = Screen.ActiveForm For Each Ctl In Frm.Controls Select Case Ctl.ControlType Case acTextBox, acComboBox, acListBox, acCheckBox, acOptionButton, acOptionGroup If IsNull(Ctl.value) Or Ctl.value = "" Then Ctl.Visible = False End If End Select Next Ctl Set Frm = Nothing End Sub '------------------------------------------------------------------- Public Sub ShowOrHideReportControls() Dim Rpt As Report Dim Ctl As Control Set Rpt = Screen.ActiveReport For Each Ctl In Rpt.Controls Select Case Ctl.ControlType Case acTextBox, acComboBox, acListBox, acCheckBox, acOptionButton, acOptionGroup If IsNull(Ctl.value) Or Ctl.value = "" Then Ctl.Visible = False End If End Select Next Ctl Set Rpt = Nothing End Sub وتنادي كل دالة باسمها حسب الاستخدام هكذا : ' للنماذج Call ShowOrHideFormControls() ' للتقارير Call ShowOrHideReportControls()

عملت فيديو يوتيوب قديما اضغط هنا تابع من الدقيقة ٣٥