بالملف المرفق طلب لاحد الاعضاء في ايجاد كود للاستدعاء بيانات من شيتات معينة ووضعها بسبت رأيسي
بجانب انهاء البيانات بتوقيع
بجانب تنسيق البيانات اذا زادة حجم البيانات المستدعاه اكبر من 50 بيان
إضافة بخلية اخرى اذا كان ما بها من بيانات يحذف القديمة ويضع بيانات من جديد
وانا قمت بإضافة ترقيم في خلية المسلسل "أظن انى ملغبط فيه"

المطلوب هو بعد اذن الخبراء مراجعت الكود والإقاف ما مدى دقت تنفيذ العمل من عدمة وهل كان هناك اختصار للأمر افضل من ذالك

ولكم جزيل الشكر
الكود هو

Sub test()
Dim was      As Worksheet
Dim ws       As Worksheet
Dim i        As String
Dim ii       As String
Dim lr       As Long
Dim lr2      As Long
Dim x, myArray, mm

Application.ScreenUpdating = False

Set was = Sheets("قائمة مطعم")
i = was.Range("f2").Value
ii = was.Range("f1").Value
Set ws = Sheets(i)

lr = was.Cells(Rows.Count, 2).End(xlUp).Row
lr2 = ws.Cells(Rows.Count, 2).End(xlUp).Row

If ii = "نعم" Then
was.Range("a12:e" & lr + 1).Clear  'مسح نطاق البحث القديم
lr = was.Cells(Rows.Count, 2).End(xlUp).Row
End If

myArray = ws.Range("A2:q" & lr2 + 1)

    ReDim y(1 To lr2, 1 To 17)
    For x = 1 To lr2 - 1
    If i = "" Then Exit Sub
         rw = rw + 1
'         y(rw, 1) = myArray(x, 1)
         If was.Range("a12").Value = "" Then y(rw, 1) = rw Else y(rw, 1) = lr - 11 + rw
         y(rw, 2) = myArray(x, 4)
         y(rw, 3) = myArray(x, 3)
         y(rw, 4) = myArray(x, 17)
         y(rw, 5) = myArray(x, 7)
    
     Next x
    If was.Range("a12").Value = "" Then
    If rw > 0 Then was.Cells(lr, 2)(2, 0).Resize(rw, 5).Value = y()
lr = was.Cells(Rows.Count, 2).End(xlUp).Row
    was.Range("a" & lr + 1).Value = "إمضاء وختم مدير المدرسة"
    was.Range("d" & lr + 1).Value = "إمضاء وختم مستشار التغذية"
    Else
    If rw > 0 Then was.Cells(lr - 1, 2)(2, 0).Resize(rw, 5).Value = y()
lr = was.Cells(Rows.Count, 2).End(xlUp).Row
    was.Range("a" & lr + 1).Value = "إمضاء وختم مدير المدرسة"
    was.Range("d" & lr + 1).Value = "إمضاء وختم مستشار التغذية"
    End If


    '=================تنسيق
lr = was.Cells(Rows.Count, 2).End(xlUp).Row
    If lr > 61 Then 'طلبك 50 صف بجانب 11 صف بالاعلى اذا الشطر يكون 61 صف
        was.Range("A12:e" & lr).Borders.Weight = 3
        was.Range("A12:e" & lr).VerticalAlignment = xlCenter
        was.Range("A12:e" & lr).HorizontalAlignment = xlCenter
        was.Columns("A:A").ColumnWidth = 8: was.Columns("B:c").ColumnWidth = 12
        was.Columns("d:d").ColumnWidth = 15: was.Columns("e:e").ColumnWidth = 10
        was.Cells.Font.Size = 16: was.Cells.Font.Bold = True

    End If

Application.ScreenUpdating = True

End Sub

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

تنسيق شرطي لسطور حسب بيانات مدخلة.rar
تحياتى وتقديرى للجميع