سليم حاصبيا

حاضر يا صديقي ABO_AZ NEW.xlsx

جرب هذا الملف مع خيار بداية الترقيم في الخلية D2 والتناقص في الخلية B2 ABO_AZ.xlsx

على كل حال لا أعرف اذا كنت تستعمل الكومبو بوكس على الشيت ام على اليوزرفورم في حال على الشيت الماكرو الاول على اليوزر الماكرو الثاني Option Explicit Sub test_For_Sheets() Dim x%, i% With ActiveSheet For i = 3 To 9 x = x + (.OLEObjects("ComboBox" & i).Object.Value = _ .OLEObjects("ComboBox2").Object.Value) Next End With If x < 0 Then MsgBox "Duplicate " & -x & " Times" Else MsgBox "No Duplicate" End If End Sub '++++++++++++++++++++++++++++++++++++++ Sub test_For_User_form() Dim x%, i% With Me For i = 3 To 9 x = x + (.Controls("ComboBox" & i).Value = _ .Controls("ComboBox2").Value) Next End With If x < 0 Then MsgBox "Duplicate " & -x & " Times" Else MsgBox "No Duplicate" End If End Sub

و هل تريد من من سيقوم بالمساعدة ان يقوم بإنشاء يوزر يحتوي عل 9 كومبو بوكس و يضع في كل واحد قيمة معينة ليتأكد من المعادلة

مع انني لا أحب ان اتعاطى مع اليوزر فورم بجميع اشكاله لكن بما انك عضو جديد فأهلاً وسهلاً بك جرب هذا الملف تم وضع كود لزر الاضافة يمكنك اضافة الأكواد لبقية الأزرار Moh_Mos.xlsm

لا أعلم ما سبب هذه الرسالة على كل حال انسخ الكود الى ملفك الأصلي ( في موديل مستقل ) وقم يانشاء شيت جديد تحت اسم Final_Sheets و نفذ الكود

تم معالجة الأمر Option Explicit Dim N As Worksheet, D As Worksheet Dim F As Worksheet Dim i%, X%, m%, t%, p%, Ar_name() Dim My_Rg As Range, Find_rg As Range '+++++++++++++++++++++++++++++++++++++++++++ Sub get_names() Dim Dic As Object, Ky, arr Set N = Sheets("names") Set D = Sheets("Final_Sheets") D.Range("C3").CurrentRegion.Clear Set Dic = CreateObject("Scripting.Dictionary") m = 3 For i = 2 To 12 Step 2 X = 2 Do Until N.Cells(X, i) = vbNullString If Not Dic.Exists(N.Cells(X, i).Value) Then Dic(N.Cells(X, i).Value) = N.Cells(X, i).Address(0, 0) Else Dic(N.Cells(X, i).Value) = _ Dic(N.Cells(X, i).Value) & "*" & N.Cells(X, i).Address(0, 0) End If X = X + 1 Loop Next i For Each Ky In Dic.keys D.Range("D" & m) = Ky arr = Split(Dic(Ky), "*") D.Range("F" & m).Resize(, UBound(arr) + 1) = arr D.Range("C" & m) = UBound(arr) + 1 m = m + 1 Next get_column With D.Range("C3").CurrentRegion.SpecialCells(2) .Borders.LineStyle = 1 .Font.Size = 16: .Font.Bold = True .InsertIndent 1 .Interior.ColorIndex = 35 End With Set Dic = Nothing End Sub '+++++++++++++++++++++++++++++++++++++++++++++++ Sub get_column() Set N = Sheets("names") Set F = Sheets("Final_Sheets") X = 3: t = 1 Do Until F.Cells(X, 4) = vbNullString For i = 2 To 12 Step 2 Set My_Rg = N.Cells(1, i).Resize(1000) Set Find_rg = My_Rg.Find(F.Cells(X, 4), lookat:=1) If Not Find_rg Is Nothing Then p = Application.CountIf(My_Rg, F.Cells(X, 4)) ReDim Preserve Ar_name(1 To t) Ar_name(t) = N.Cells(1, i) & ":" & p & " " t = t + 1 End If Next i If t > 1 Then F.Cells(X, 5) = Join(Ar_name, ";") End If Erase Ar_name: t = 1 X = X + 1 Loop End Sub الملف مرفق صفحة Final Sheets Com_1975_New.xlsm

ربما هذا الشيء هو المطلوب وضعت لك كود لزر اضافة يرجى اكمال كودات بقية الأزرار Ahmad User.xlsm

تم التعديل كمكا تريد (التكرار حسب الأعمدة )صفحة Salim من هذا الملف مع الاجتفاظ بالماكرو السابق في ضفحة Data Option Explicit Sub get_names_by_col() Dim N As Worksheet, SA As Worksheet Dim Dic As Object, Ky, arr, kyb Dim i%, X%, m%: m = 5 Dim t%: t = 3 Set N = Sheets("names") Set SA = Sheets("Salim") SA.Range("C5").CurrentRegion.Clear Set Dic = CreateObject("Scripting.Dictionary") For i = 2 To 12 Step 2 X = 2 Do Until N.Cells(X, i) = vbNullString If Not Dic.Exists(N.Cells(X, i).Value) Then Dic(N.Cells(X, i).Value) = _ N.Cells(X, i).Address Else Dic(N.Cells(X, i).Value) = _ Dic(N.Cells(X, i).Value) & _ "*" & N.Cells(X, i).Address End If X = X + 1 Loop If Dic.Count Then For Each Ky In Dic.keys SA.Cells(m, t) = Ky arr = Split(Dic(Ky), "*") SA.Cells(m, t + 1) = UBound(arr) + 1 m = m + 1 Next Ky End If t = t + 2: m = 5 Dic.RemoveAll Next i With SA.Range("C5").CurrentRegion.SpecialCells(2) .Borders.LineStyle = 1 .Font.Size = 16: .Font.Bold = True .InsertIndent 1 .Interior.ColorIndex = 35 End With Set Dic = Nothing Set N = Nothing: Set SA = Nothing End Sub الملف الجديد مرفق Com_1975_by_columns.xlsm

جرب هذا الملف لا لزوم لهذه الكمية من الداتا يكفي 10 -- 15 صف لاختبار الكود Option Explicit Sub get_names() Dim N As Worksheet, D As Worksheet Dim Dic As Object, Ky, arr Dim i%, X%, m%: m = 3 Set N = Sheets("names") Set D = Sheets("Data") D.Range("c3").CurrentRegion.Clear Set Dic = CreateObject("Scripting.Dictionary") For i = 2 To 12 Step 2 X = 2 Do Until N.Cells(X, i) = vbNullString If Not Dic.Exists(N.Cells(X, i).Value) Then Dic(N.Cells(X, i).Value) = N.Cells(X, i).Address Else Dic(N.Cells(X, i).Value) = Dic(N.Cells(X, i).Value) & "*" & N.Cells(X, i).Address End If X = X + 1 Loop Next i For Each Ky In Dic.keys D.Range("D" & m) = Ky arr = Split(Dic(Ky), "*") D.Range("E" & m).Resize(, UBound(arr) + 1) = arr D.Range("C" & m) = UBound(arr) + 1 m = m + 1 Next With D.Range("C3").CurrentRegion.SpecialCells(2) .Borders.LineStyle = 1 .Font.Size = 16: .Font.Bold = True .InsertIndent 1 .Interior.ColorIndex = 35 End With Set Dic = Nothing End Sub الملف مرفق Com_1975.xlsm

الخلايا المدمجة ثؤثر على عمل اي ماكرو لذلك تم ازالة تالخلايا المدمجة من الصف خيث يوحد رقم السنة في اي صفحة حدد السنة التي تريد من الخلية R1 واضغط الزر Hid rows ولاطهار المخفي اضغط Show rows الملف مرفق من جديد Muneef_1.xlsm

بالمعادلات لا تستطيع ضبط هذا الشيء فقط بواسطة كود Vba للمزيد هذا الملف 1-يمنع الكتابة في العامودين الاول والثاني ابتداء من ال صف 14 لعدم مسح لبيانات عن طريق الخطأ 2- كل ما عليك ان تملاُ ما تريد من بيانات في الأعمدة 3 /4 /5 (ابتداء من الصف 14 ونزولاً) وبعد ذلك تضغظ الزر Run عندها يقوم الاكسل بادراح التاريخ المناسب و يثبته 3-عدة مرات انصح لعدم استعمال الخلايا المدمحة لحسن سير المعادلات الجدول R5 : G2 STOCK_Salim.xlsm

جرب هذا الملف اكتب فقط رقم الشهر الذي تريد في الخلية F1 في اي صفحة والتاريخ يتجدث تلقائياً واذا كان اسم الشهر (C1) يساوي اسم الصفحة يتم اخفاء الصفوف التي تريد Muneef.xlsm

كبسة يمين عليه ثم Edit Text

اليس من الأفضل والاسهل الكتابة في خلية بدلاً من الــــ TextBox على كل حال لك ما طلبت بعد تعيئةالـــ TextBox بالاسم الصحيح دون زيادة مسافات أو نقصانها و التقيد بحرف الالف (مع همزة او بدونها ) و حرف الياء في اخر الكلمة (مع نقاط او بدونها) اضغط على الخلية I1 Sooos_1.xlsm

هذه المعادلة واسحب نزولاً =IF(COUNT($D4:$F4),TODAY(),"")

لا أفهم ما لزوم هذه التكسيوكسات الكثيرة (12) في حين نحن لسنا بحاجة الى اي منها جرب هذا الكود الذي يقوم بانشاء قائمة منسدلة مطاطة (بدون تكرار) كلما عدلت في الأسماء او اضفت اسماء جديدة وعلى اساسها تجد ماتريد Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Not Intersect(Target, Range("I4:I100")) Is Nothing _ And Target.Count = 1 Then data_VAL End If Application.EnableEvents = True End Sub '++++++++++++++++++++++++++++++++++++++++++ Sub data_VAL() Dim RO%, i%, Obj As Object Set Obj = CreateObject("Scripting.Dictionary") With Me RO = .Cells(Rows.Count, "I").End(3).Row If RO < 4 Then RO = 4 For i = 4 To RO If .Cells(i, "I") <> vbNullString Then Obj(.Cells(i, "I").Value) = vbNullString End If Next If Obj.Count Then With .Cells(2, "I").Validation .Delete .Add 3, Formula1:=Join(Obj.keys, ",") End With End If End With End Sub Sooos.xlsm

لم افهم ما المشكلة عندي اليوزر يعمل على اي صفحة تم التعديل على الماكرو بحيث تستطيغ التنقل داخل الشبت ومن شيت الى اخر حتى ولو كان اليوزر ظاهراً بمعنى اخر بعد تعبئة الفورم (اذا اردت ان تكون البيانات في شيت اخرى) حدد الصقحة التي تريد واضغط على اضافة عليك فقط استكمال اكواد باقي الأزرار يمنكن ايضاَ الاستعانة الملف Sal_User بعد نعديل الأكواد كما يلزم الملف مرفق Ahmaad_Housni_User.xlsm Sal_User.xlsm

طالما ان تستعمل activesheet فان الماكرو ينفذ على الشيت النشطة مثال كود للزر الاول والثاني (طبقه على بقية الأزار) Dim sh As Worksheet, lrow As Long, i As Long Private Sub CommandButton1_Click() Application.EnableEvents = False If TextBox1.Value <> "" And _ TextBox2.Value <> "" And TextBox3 <> "" _ And TextBox4.Value <> "" _ And TextBox5.Value <> "" Then Set sh = ActiveSheet With sh lrow = .Range("B" & Rows.Count).End(xlUp).Row With .Range("B" & lrow + 1) For i = 1 To 5 .Offset(, i - 1) = _ Me.Controls("TextBox" & i).Value Me.Controls("TextBox" & i).Value = "" Next End With End With Else MsgBox ("InComplete data") End If Application.EnableEvents = True End Sub '++++++++++++++++++++++++++++++++++++++++ Private Sub CommandButton2_Click() Set sh = ActiveSheet For i = 2 To 5 Me.Controls("TextBox" & i).Value = "" Next lrow = sh.Range("B" & Rows.Count).End(xlUp).Row For i = 2 To lrow If sh.Cells(i, 2) = TextBox1.Text Then sh.Cells(i, 2).Select Exit For End If Next i For i = 2 To 4 With ActiveCell .Offset(0, i - 1) = Me.Controls("TextBox" & i).Text End With End Sub

يمكن اختصار الكود لكل زر على النحو التالي (مثال على الزر رقم 1) Dim sh As Worksheet, lrow As Long Private Sub CommandButton1_Click() Application.EnableEvents = False If TextBox1.Value <> "" And _ TextBox2.Value <> "" And TextBox3 <> "" _ And TextBox4.Value <> "" _ And TextBox5.Value <> "" Then Set sh = ActiveSheet Dim i With sh lrow = .Range("B" & Rows.Count).End(xlUp).Row With .Range("B" & lrow + 1) For i = 1 To 5 .Offset(, i - 1) = _ Me.Controls("TextBox" & i).Value Me.Controls("TextBox" & i).Value = "" Next End With End With Else MsgBox ("InComplete data") End If Application.EnableEvents = True End Sub

بعد اذن الأخ أمين هذا الملف adelalmalki.xlsm

غير تنسيق الخلايا في العامود المناسب الى General و تعود هذه الخلايا الى طبيعتها

جرب هذا الكود 1-يقوم بادراج قائمة منسدلة بدون تكرار ومرتبة ابجدياً 2-يعمل اوتوماتيكياً عند فتح الملف Option Explicit Private Sub Worksheet_Activate() Salim_Data_Val End Sub '+++++++++++++++++++++++++++++++++++ Sub Salim_Data_Val() Dim B As Worksheet, W As Worksheet Set B = Sheets("البيانات الرئيسية") Set W = Sheets("الوظيفة") Dim i#: i = 7 Dim arr Dim Laste_row# Laste_row = B.Cells(Rows.Count, "D").End(3).Row Dim rg As Object Set rg = CreateObject("System.Collections.Arraylist") With rg Do Until i > Laste_row If Not .Contains(UCase(B.Range("D" & i).Value)) _ And B.Range("D" & i) <> vbNullString Then _ .Add UCase(B.Range("D" & i).Value) i = i + 1 Loop .Sort arr = Join(.Toarray, ",") End With With W.Range("H2").Validation .Delete .Add xlValidateList, Formula1:=arr End With Set rg = Nothing: Set B = Nothing: Set W = Nothing End Sub الملف مرفق hamed_1.xls

اذا تحقق ما تريد و حصلت على الجواب الشافي اضغط على أفضل اجابة ( علامة الـــ صح الى يمين اخر مشاركة لي ) لاغلاق الموضوغ

كبف عرفت انه المطلوب حتى و لم تنزل الملف على الجهاز عندك