اضافة شرط لكود الاضافة

[ابو حمادة]

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

استذتي الكرام 

عندي ملف به بيانات كثيره جدا وتم عمل فورم لاضافه اي تعديل على كل الاسماء ومحتاج الاتي

كل 10 اسماء بيتم تحديد لهم نوع الكشف  الخاص بهم في العمود ()

المطلوب

محتاج اضافه حللقه تكراريه لكود الاضافه الموجود باليوزر فورم يعملل الاتي

يخصص لكل 10 اسماء نوع كشف معين بحيث عند الاضافه يتم  اول 10 اسماء يحدد لهم ( كشف 1 ) ثم يليه 10 اسماء  ( كشف 2 ) وهكذا الى نهاية الاسماء 

مرفق صورة لتوضيح المطلوب وايضا ملف للعمل عليه 

اضافه1.rar

[سليم حاصبيا]

حرب هذا الملف

تستطيع ان تتعامل طبيعياً مع الورقة حتى و لو كان اليوزر ظاهراً

الكود

Option Explicit

Private Sub Command1_Click()
Application.ScreenUpdating = False
Dim arr(), str$
Dim k%, x%, My_Num, lr%, i%, t%
Dim sh As Worksheet: Set sh = Sheets("add")
My_Num = sh.[j6]
 If Not IsNumeric(My_Num) Or My_Num < 1 _
 Or My_Num = vbNullString Then
 My_Num = 10
 Else
 My_Num = Int(My_Num)
End If
k = 1
    lr = sh.Cells(Rows.Count, "B").End(xlUp).Row
    sh.Range("e2:f" & lr).ClearContents
     For i = 6 To lr Step My_Num
       x = InStr(Me.TextBox2, " ")
        str = Left(Me.TextBox2, x - 1)
        str = str & k
     If lr - i < My_Num Then
        t = lr - i + 1
        sh.Range("f" & i).Resize(t) = Me.TextBox3
        sh.Range("e" & i).Resize(t) = str: Exit For
     End If
    sh.Range("f" & i).Resize(My_Num) = Me.TextBox3
   sh.Range("e" & i).Resize(My_Num - t) = str
    k = k + 1
       Next
Application.ScreenUpdating = True
'Unload Me 'تستطيع تشغيل هذا السطر اذا اردت ان يختفي الفورم
 End Sub

الملف

 

اضافه1 Salim.rar

[ابو حمادة]

48 دقائق مضت, سليم حاصبيا said:

حرب هذا الملف

تستطيع ان تتعامل طبيعياً مع الورقة حتى و لو كان اليوزر ظاهراً

الكود

Option Explicit

Private Sub Command1_Click()
Application.ScreenUpdating = False
Dim arr(), str$
Dim k%, x%, My_Num, lr%, i%, t%
Dim sh As Worksheet: Set sh = Sheets("add")
My_Num = sh.[j6]
 If Not IsNumeric(My_Num) Or My_Num < 1 _
 Or My_Num = vbNullString Then
 My_Num = 10
 Else
 My_Num = Int(My_Num)
End If
k = 1
    lr = sh.Cells(Rows.Count, "B").End(xlUp).Row
    sh.Range("e2:f" & lr).ClearContents
     For i = 6 To lr Step My_Num
       x = InStr(Me.TextBox2, " ")
        str = Left(Me.TextBox2, x - 1)
        str = str & k
     If lr - i < My_Num Then
        t = lr - i + 1
        sh.Range("f" & i).Resize(t) = Me.TextBox3
        sh.Range("e" & i).Resize(t) = str: Exit For
     End If
    sh.Range("f" & i).Resize(My_Num) = Me.TextBox3
   sh.Range("e" & i).Resize(My_Num - t) = str
    k = k + 1
       Next
Application.ScreenUpdating = True
'Unload Me 'تستطيع تشغيل هذا السطر اذا اردت ان يختفي الفورم
 End Sub

الملف

 

اضافه1 Salim.rar

والله بجد تسلم ايدك الله ينور عليك وزادك الله علما نافعا ووسع رزقك في الدنيا والاخره