تحد عدد الصفوف

[Akram Galal]

أعضاء المنتدي الكرام

أرجوا من الله أن تكونوا في أفضل حال

لدي ملف يقوم بإظهار صف تكست بوكس جديد عند الضغط على مفتاح Enter

وأ

ريد طلبين

الأول: أن لا يزيد عدد صفوف التكست بوكس عن 20 صف فقط لاغير

الثاني: لا يسمح بترحيل البيانات إذا كان أحد التكست بوكس فارغ

ولكم كل الشكر والإحترام

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

مع العلم أن هذا العمل للعلامة الكبير عبد الله بقشير

وإليكم المرفقات

إظهار صف تكست بوكس جديد عند الضغط على مفتاح Enter 2.rar

تم تعديل سبتمبر 23, 2012 بواسطه Akram Galal

[أبو حنــــين]

هذا بالنسبة للطلب الاول

Private Sub kh_AddContl()

Dim MyName As String

Dim MyFrmLeft As Double, ScHght As Double

Dim MyLeft As Double, MyWidth As Double

Dim i As Integer

''''''''''''''''''''''''''''''''''''''''''''''''''''''''

If MyCont = 20 Then Exit Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''

MyCont = MyCont + 1

ScHght = (MyCont * iTop) + Frmtop

''''''''''''''''''''''''''''''''''''''''''''''''''''''''

With Me.FrameList

    If ScHght > .Height Then .ScrollHeight = ScHght

    MyFrmLeft = .Left + .Width - .InsideWidth

End With

''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    For i = 1 To 6

	    MyWidth = Me.Controls("LabelZ" & i).Width

	    MyLeft = Me.Controls("LabelZ" & i).Left - MyFrmLeft

	    MyName = Cells(MyCont, i).Address

	    With Me.FrameList.Controls.Add("Forms.TextBox.1", MyName, True)

		    .Move MyLeft, MyTop, MyWidth, iHt

		    .TextAlign = 3

	    End With

    Next

    MyTop = MyTop + iTop

'''''''''''''''''''''''''''''''''''''''''''''''''

End Sub

[Akram Galal]

جزاك الله خيرا يا أبو حنين

وبارك الله لك في حنين

ولكني أطمع في طلب صغير

وهو أن يمنع ترحيل البيانات بعد السطر رقم 20

ولكم من كل الإحترام والتقدير.

[الـعيدروس]

السلام عليكم

طلبك الثاني

استبدل هذه الاكواد بكود زر الترحيل

Private Sub Kh_E()

On Error Resume Next

Dim cotl As Control

Dim LastRow As Long

Dim Addrs As String

''''''''''''''

LastRow = Sheets("Data").Cells(Rows.Count, "A").End(xlUp).Row + 1

''''''''''''''

For Each cotl In Me.FrameList.Controls

    If Len(Trim(cotl)) Then

	    Addrs = cotl.Name

	    Sheets("Data").Cells(LastRow, "A").Range(Addrs).Value = cotl.Value

    End If

Next

End Sub

Private Sub CommandButton1_Click()

On Error Resume Next

Dim CO As MSForms.TextBox

Dim AA%

Dim MS As String

For Each CO In Me.FrameList.Controls

If CO.Value = "" Then

MS = MS & AA

AA = AA + 1

Else

Kh_E

End If

Next

MsgBox "يوجد " & " : " & Len(MS) & " ] " & " حقل فارغ لايمكن الترحيل اكمل تعبئة الحقول الفارغه" & " ] ", vbCritical

End Sub

تم تعديل سبتمبر 23, 2012 بواسطه عباد