عبدالله باقشير

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

السلام عليكم جزاكم الله خيرا تقبلوا تحياتي وشكري

السلام عليكم جزاكم الله خيرا اخي الكريم ياسر ائراءا للموضوع بدون استخدام معادلات على الخلايا Sub kh_Start() Dim obj Dim Lr As Integer, iRnd As Integer, i As Integer Lr = Cells(Rows.Count, "A").End(xlUp).Row - 1 '======================================== Set obj = CreateObject("Scripting.Dictionary") '======================================== Do iRnd = Int((Rnd * Lr) + 1) If Not obj.Exists(iRnd) Then i = i + 1 obj.Add iRnd, i Range("F2").Cells(i, 1).Resize(1, 2).Value = Range("A2").Cells(iRnd, 1).Resize(1, 2).Value End If If i = 10 Then Exit Do Loop Set obj = Nothing End Sub المرفق 2003 Random word Generator2.rar

السلام عليكم اذا كان هناك تعليق على الخلية سيقوم باضافة قائمة وسيقوم باستخدام الاسم الموجود في التعليق لنطاق القائمة شاهد المرفق 2003 FrameScrollBars1.rar

الله يسلمك ...........جزاكم الله خير بالنسبة لسؤالك يمكنك تغيير الخاصية KeepScrollBarsVisible الى الخيار 0 (fmScrollBarsNone) اثناء التصميم تحياتي بارك الله فيك أستاذي العلامة القديرعلى هذه المساعدة ياريت إضافة للكود ماهي الطريقة لتغيير تكست بوكس إلى كمبوبوكس بخاصية إدارة الأسماء كما فعلت في ملفك كود بحث وتعديل مرن اريد كود سهل وسلس بعيد عند تلك الأكواد المعقدة مثلا في العمود الثالث في الفورم اريد ان يظهر كمبوبوكس مكان تكست بوكس وهكذا حسب إختياري للعمود جزاكم الله خيرا اذا كان هناك تعليق على الخلية سيقوم باضافة قائمة Private Sub UserForm_Activate() Dim Sh As Worksheet Dim txt As MSForms.Control Dim LastCol As Integer, i As Integer Set Sh = ThisWorkbook.Sheets(1) LastCol = Sh.Cells(2, Sh.Columns.Count).End(xlToLeft).Column MyTop = 10 For i = 1 To LastCol If Not Sh.Cells(2, i).Comment Is Nothing Then Set txt = Frame1.Controls.Add("Forms.Combobox.1", "MyTxt" & i) Else Set txt = Frame1.Controls.Add("Forms.TextBox.1", "MyTxt" & i) End If With txt .Move 20, MyTop, 114, 24 .Text = Sh.Cells(2, i) .SpecialEffect = fmSpecialEffectSunken .TextAlign = fmTextAlignCenter .BackColor = &HFFFFFF End With MyTop = MyTop + 30 Next Me.Frame1.ScrollHeight = MyTop End Sub المرفق 2003

بارك الله فيك / العلامة عبد الله باقشير أولا وقبل كل شيء الحمد لله على سلامتك إن شاء الله ما أبعدك عنا غير الخير سعدت جدا بمرورك وتعديلك أستاذي ملاحظة بسيطه عند إنقاص البيانات من الأعمدة مثلا تركت 5 بياناات فقط السكرول بار يبقى ظاهر لكن خاصية التمرير لا تظهر هل من إضافة للكود بحيث اذا نقصت البيانات لا يظهر السكرول بار الله يسلمك ...........جزاكم الله خير بالنسبة لسؤالك يمكنك تغيير الخاصية KeepScrollBarsVisible الى الخيار 0 (fmScrollBarsNone) اثناء التصميم تحياتي

السلام عليكم جرب هذا Private Sub UserForm_Activate() Dim Sh As Object Dim LastCol, i As Integer Set Sh = ThisWorkbook.Sheets(1) LastCol = Cells(2, Sh.Columns.Count).End(xlToLeft).Column MyTop = 10 For i = 1 To LastCol Set txt = Frame1.Controls.Add("Forms.TextBox.1", "TextBox" & i) With txt .Text = Cells(2, i) .SpecialEffect = fmSpecialEffectSunken .TextAlign = fmTextAlignCenter .Top = MyTop .Left = 20 .Height = 24 .Width = 114 .BackColor = &HFFFFFF End With MyTop = MyTop + 30 Next Me.Frame1.ScrollHeight = MyTop End Sub

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

السلام عليكم جزاكم الله خيرا تقبلوا تحياتي وشكري

عدل هذا السطر هكذا For iI = lLrw To 2 Step -1

السلام عليكم الشكر واصل للاخ ابو تراب............ حفظه الله وائراءا للموضوع ممكن استخدام هذا الكود التالي بدون تحديد اسماء للبوكس شيك ولا للخلايا تستدل بالخلايا بموضع الشيك بوكس Sub kh_UpdateBoxes() Dim tx As String On Error Resume Next With Sheet1.Shapes(Application.Caller) If .ControlFormat.Value = 1 Then tx = "*" Else tx = "" .TopLeftCell.Offset(1, 0).Value = tx End With On Error GoTo 0 End Sub المرفق 2010 تشيك بوكس.rar

وعليكم السلام محاولة للإجابة على لغز جدول متحرك ضع هذه المعادلة في الخلية B4 ثتم إسحب الى الأسفل والى اليسار =IF(OR(ROW()-3>$J$2;COLUMN()-1>$K$2);"";((COLUMN()-2)*$J$2)+ROW()-3) تحياتي

هذا التعبير للعمود الثاني Me.ListFind.Column(1) وهذا للثالث Me.ListFind.Column(2) وهكذا ................. تحياتي

السلام عليكم http://www.officena.net/ib/index.php?showtopic=14415

جزاكم الله خيرا

السلام عليكم ما شاء الله فكرة ذكية .........جزاكم الله خيرا تقبلوا تحياتي وشكري

السلام عليكم جزاك الله خير اخي المجتهد ابن مصر هذا اختصار بسيط للكود ائراءا للموضوع Sub cmdRename_EN_Click() Dim i As Integer On Error Resume Next For i = 1 To Sheets.Count ThisWorkbook.VBProject.VBComponents(Sheets(i).Name).Name = "sheets" & i Sheets(i).Name = "sheets" & i Next End Sub Sub cmdRename_AR_Click() Dim i As Integer On Error Resume Next For i = 1 To Sheets.Count ThisWorkbook.VBProject.VBComponents(Sheets(i).Name).Name = "ورقة" & i Sheets(i).Name = "ورقة" & i Next End Sub تحياتي

شاهد المرفق 2010 Insert Vacc Code_Req-233.rar

استبدل بهذا Sub kh_tst() Dim v Dim Rng As Range Dim R As Long, m As Long Dim c As Integer On Error GoTo 1 With Sheets("Vacc").Range("A2") Set Rng = Range(.Cells, .Cells.End(xlDown)) End With With Sheets("Report") For R = 3 To .Cells(Rows.Count, "B").End(xlUp).Row m = Val(CStr(Application.Match(Val(.Cells(R, "B")), Rng, 0))) If m Then For Each v In Split(Rng.Cells(m, 2), "+") c = Val(v) If c Then With .Cells(R, "B").Offset(0, c) If Val(.Cells) Then .Interior.Color = vbRed Else .Value = "ج" End With End If Next End If Next End With 1 If Err Then MsgBox Err.Number, vbCritical, "Error Number " Set Rng = Nothing End Sub تحياتي

ان شاء الله جرب واشعرنا بالنتيجة

السلام عليكم جرب الكود التالي لا يتم كتابة الحرف "ج" الا على الخلايا التي تحتوى على الرقم "0" فقط وغيرة يتم تلوين الخلية الى الاحمر Sub kh_tst() Dim v Dim Rng As Range Dim R As Long, m As Long Dim c As Integer On Error GoTo 1 With Sheets("Vacc").Range("A2") Set Rng = Range(.Cells, .Cells.End(xlDown)) End With With Sheets("Report") For R = 3 To .Cells(Rows.Count, "B").End(xlUp).Row m = Val(CStr(Application.Match(CStr(.Cells(R, "B")), Rng, 0))) If m Then For Each v In Split(Rng.Cells(m, 2), "+") c = Val(v) If c Then With .Cells(R, "B").Offset(0, c) If Val(.Cells) Then .Interior.Color = vbRed Else .Value = "ج" End With End If Next End If Next End With 1 If Err Then MsgBox Err.Number, vbCritical, "Error Number " Set Rng = Nothing End Sub شاهد المرفق 2010 تحياتي Insert Vacc Code_Req.rar

جزاكم الله خيرا

جزاكم الله خيرا