اذهب الي المحتوي
أوفيسنا

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

المشرفين السابقين
 عرض الملف الشخصي  عرض المشاركات

  • Posts

    4796

  • تاريخ الانضمام

  • تاريخ اخر زياره

  • Days Won

    57

 نوع المحتوي 

مشاركات المكتوبه بواسطه عبدالله باقشير

    توليد كلمات عشوائية

    في منتدى الاكسيل Excel

    قام بنشر

    السلام عليكم

     

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

     

    ائراءا للموضوع

    بدون استخدام معادلات على الخلايا

    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

    • Like 4

    هل من طريقة في التحكم في Scroll Bars الخاص Frame بمدى ديناميكي

    في منتدى الاكسيل Excel

    قام بنشر

     

     

     

     

     

     

     

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

    بالنسبة لسؤالك يمكنك تغيير الخاصية

    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

    • Like 1

    هل من طريقة في التحكم في Scroll Bars الخاص Frame بمدى ديناميكي

    في منتدى الاكسيل Excel

    قام بنشر

     

     

    السلام عليكم

     

    جرب هذا

    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

     

    بارك الله فيك / العلامة عبد الله باقشير

    أولا وقبل كل شيء الحمد لله على سلامتك إن شاء الله ما أبعدك عنا غير الخير

    سعدت جدا بمرورك وتعديلك

    أستاذي ملاحظة بسيطه  عند إنقاص البيانات من الأعمدة مثلا تركت 5 بياناات فقط

    السكرول بار يبقى ظاهر لكن خاصية التمرير لا تظهر

    هل من إضافة للكود بحيث اذا نقصت البيانات لا يظهر السكرول بار

     

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

    بالنسبة لسؤالك يمكنك تغيير الخاصية

    KeepScrollBarsVisible الى الخيار 0 (fmScrollBarsNone)  اثناء التصميم

     

    تحياتي

    • Like 1

    هل من طريقة في التحكم في Scroll Bars الخاص Frame بمدى ديناميكي

    في منتدى الاكسيل Excel

    قام بنشر

    السلام عليكم

     

    جرب هذا

    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
    • Like 1

    طلب مساعدة كود للتشيك بوكس

    في منتدى الاكسيل Excel

    قام بنشر

    السلام عليكم

     

    الشكر واصل للاخ ابو تراب............ حفظه الله

     

    وائراءا للموضوع

     

    ممكن استخدام هذا الكود التالي  بدون تحديد اسماء للبوكس شيك ولا للخلايا

    تستدل بالخلايا بموضع الشيك بوكس


    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

    • Like 3

    ترحيل من الليست بوكس إلي التيكست بوكس

    في منتدى الاكسيل Excel

    قام بنشر

    أستاذنا الفاضل/ عبد الله باقشير

    السادة أعضاء المنتدى

    ألا يوجد حل للطلب الأخير

    وهو

    ماذا لو أردنا ترحيل العمود الثاني أو الثالث

    من الليست بوكس إلي التيكست بوكس

    بدلا من العمود الأول

    وجزاكم الله خيراً .

    هذا التعبير للعمود الثاني

    Me.ListFind.Column(1)

    وهذا للثالث

    Me.ListFind.Column(2)

    وهكذا .................

    تحياتي

    مساعدةفي ماكرو تغيير إسم الورقة

    في منتدى الاكسيل Excel

    قام بنشر

    السلام عليكم

     

    جزاك الله خير اخي المجتهد ابن مصر

     

    هذا اختصار بسيط للكود ائراءا للموضوع


    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

    تحياتي

    • Like 3

    ادخال الأجازات بكود برمجى

    في منتدى الاكسيل Excel

    قام بنشر

    السلام عليكم ورحمة الله وبركاته 

     

    جربت الملف وأبدلت الاسماء إلى أرقام 

     

    ولكن لا يعمل 

     

     

    attachicon.gifInsert Vacc Code_Req-2.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

    تحياتي

    • Like 1

    ادخال الأجازات بكود برمجى

    في منتدى الاكسيل Excel

    قام بنشر

    السلام عليكم

    جرب الكود التالي

    لا يتم كتابة الحرف "ج" الا على الخلايا التي تحتوى على الرقم "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

×
×
  • اضف...

Important Information

  I accept