اختصار كود

[a.kawkab]

مطلوب اختصار الكود التالى

 

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Application.Visible = True
Sheets("الانسولين").Activate
       
'==============================================
   Dim i As Integer, j As Integer
       lrow = Range("c" & Rows.Count).End(xlUp).Row + 1
        If lrow < 5 Then lrow = 5
        If lrow > 27 Then MsgBox "انتقل للبيان التالى": GoTo 1
'        Range("c" & lrow).Value = lrow - 5
With Sheets("الانسولين")
 .Range("C5:J1000").Select
    Selection.ClearContents
        .Range("c" & lrow).Offset(0, 0).Value = TextBox1
        .Range("c" & lrow).Offset(0, 1).Value = TextBox2
        .Range("c" & lrow).Offset(0, 2).Value = TextBox3
        .Range("c" & lrow).Offset(0, 3).Value = TextBox4
        .Range("c" & lrow).Offset(0, 4).Value = TextBox5
        .Range("c" & lrow).Offset(0, 5).Value = TextBox6
        .Range("c" & lrow).Offset(0, 6).Value = TextBox7
        .Range("c" & lrow).Offset(0, 7).Value = TextBox8
        .Range("c" & lrow).Offset(1, 0).Value = TextBox9
        .Range("c" & lrow).Offset(1, 1).Value = TextBox10
        .Range("c" & lrow).Offset(1, 2).Value = TextBox11
        .Range("c" & lrow).Offset(1, 3).Value = TextBox12
        .Range("c" & lrow).Offset(1, 4).Value = TextBox13
        .Range("c" & lrow).Offset(1, 5).Value = TextBox14
        .Range("c" & lrow).Offset(1, 6).Value = TextBox15
        .Range("c" & lrow).Offset(1, 7).Value = TextBox16
        .Range("c" & lrow).Offset(2, 0).Value = TextBox17
        .Range("c" & lrow).Offset(2, 1).Value = TextBox18
        .Range("c" & lrow).Offset(2, 2).Value = TextBox19
        .Range("c" & lrow).Offset(2, 3).Value = TextBox20
        .Range("c" & lrow).Offset(2, 4).Value = TextBox21
        .Range("c" & lrow).Offset(2, 5).Value = TextBox22
        .Range("c" & lrow).Offset(2, 6).Value = TextBox23
        .Range("c" & lrow).Offset(2, 7).Value = TextBox24
        .Range("c" & lrow).Offset(3, 0).Value = TextBox25
        .Range("c" & lrow).Offset(3, 1).Value = TextBox26
        .Range("c" & lrow).Offset(3, 2).Value = TextBox27
        .Range("c" & lrow).Offset(3, 3).Value = TextBox28
        .Range("c" & lrow).Offset(3, 4).Value = TextBox29
        .Range("c" & lrow).Offset(3, 5).Value = TextBox30
        .Range("c" & lrow).Offset(3, 6).Value = TextBox31
        .Range("c" & lrow).Offset(3, 7).Value = TextBox32
1:

'    .TextBox1.SetFocus
    

ThisWorkbook.Save
End With
Application.Visible = False
Application.ScreenUpdating = True

End Sub

فى الملف المرفق فورم به 140 تكست مطلوب كود مختصر لترحيل البيانات من ال140 تكست للشيت

 

الانسولين.xlsm

[عبدالفتاح في بي اكسيل]

اين  الملف  على  حد  علمي  هذا  كود  ترحيل  والاختصار  من  اين  تريده  هل   من بداية  هذا  السطر   اما  ماذا 

.Range("c" & lrow).Offset(0, 0).Value = TextBox1

 

[a.kawkab]

نعم اريد  اختصاره من بداية هذا السطر ولان لدى فورم به 140 تكست فيوجد صعوبه فى كتابة الكود لذلك ابحث عن كود مختصر

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

جرب هذا الكود

Private Sub CommandButton1_Click()
Sheets("انسولين الهيئة").Activate
       
'==============================================
 Dim i As Integer, j As Integer, x, y
        lrow = Range("c" & Rows.Count).End(xlUp).Row + 1
        If lrow < 5 Then lrow = 5
        If lrow > 27 Then MsgBox "انتقل للبيان التالى": Exit Sub
x = 4: y = 3
With Sheets("انسولين الهيئة")
 .Range("C5:J27").ClearContents
    For i = 1 To 144
    .Cells(x, y) = Val(Me.Controls("TextBox" & i))
      y = y + 1
    If y = 11 Then y = 3: x = x + 1
   Next
 
   End With
End Sub

 

[a.kawkab]

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

اوفى الكود واراحنى ولكن لدى مشكلة صغيرة فى خلايا الجمع عندما يتم نسخ الخلايا الفارغة من الفورم يعطينى خطأ value وجربت دالة 

if error دون جدوى فاطمع فى سعة علمك لحل هذه المشكلة مرفق صورة توضيحية

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

في الخلية K4  هذه المعادلة (وليس C4+E4+G4+I4)

=SUM(C4,E4,G4,I4)

واسحب نزولاً

و كذلك في الخلية L4

=SUM(D4,F4,H4,J4)

لأن الدلة SUM  تعتبر النص(أو الفراغ) صفراً ولا تحتسبه 

[a.kawkab]

شكرا استاذنا الفاضل استاذ سليم وجزاك الله خيرا ونفعنا بعلمك تم المطلوب بحمد الله  وجزاك الله خيرا