logo

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
abdelmoniem ismail لا تميز خلال هذه الفترة-- لا تميز خلال هذه الفترة لا تميز خلال هذه الفترة توزيع المعلمين في جدول الحصص حسب النصاب بشروط اكسيل مشاريع جاهزه



أهلا وسهلا بك زائرنا الكريم في أكاديمية الصقر للتدريب، لكي تتمكن من المشاركة ومشاهدة جميع أقسام المنتدى وكافة الميزات ، يجب عليك إنشاء حساب جديد بالتسجيل بالضغط هنا أو تسجيل الدخول اضغط هنا إذا كنت عضواً .





27-11-2017 02:56 صباحاً
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 14
المشاركات : 1309
الدولة : مصر
الجنس :
تاريخ الميلاد : 4-7-1990
الدعوات : 59
قوة السمعة : 4570
الاعجاب : 0
موقعي : زيارة موقعي
بالملف المرفق طلب لاحد الاعضاء في ايجاد كود للاستدعاء بيانات من شيتات معينة ووضعها بسبت رأيسي
بجانب انهاء البيانات بتوقيع
بجانب تنسيق البيانات اذا زادة حجم البيانات المستدعاه اكبر من 50 بيان
إضافة بخلية اخرى اذا كان ما بها من بيانات يحذف القديمة ويضع بيانات من جديد
وانا قمت بإضافة ترقيم في خلية المسلسل "أظن انى ملغبط فيه"

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

ولكم جزيل الشكر
الكود هو
CODE
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


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

attachتنسيق شرطي لسطور حسب بيانات مدخلة.rar
تحياتى وتقديرى للجميع
 
 
  تنسيق شرطي لسطور حسب بيانات مدخلة.rar   تحميل rar مرات التحميل :(14)
الحجم :(83.085) KB




توقيع :محمود ابو الدهب
لى عظيم الشرف بالانضمام لهذا الصرح العظيم
وكم أتمنى من الله
ان يعيننى ويعلمنى من علمة الواسع فهو ولي ذالك وهو على كل شي قدير

تحياتى وتقدير للجميع  محمود ابوالدهب

look/images/icons/i1.gif مراجع كود استدعاء وتنسيق خلايا
  27-11-2017 02:58 صباحاً   [1]
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 14
المشاركات : 1309
الدولة : مصر
الجنس :
تاريخ الميلاد : 4-7-1990
الدعوات : 59
قوة السمعة : 4570
الاعجاب : 0
موقعي : زيارة موقعي
ارجوا نقل الملف لصفحة اكسيل اسئلة وأجوبة حيث قمت بكتابتة هنا بالخطأ وارجوا المعزرة



توقيع :محمود ابو الدهب
لى عظيم الشرف بالانضمام لهذا الصرح العظيم
وكم أتمنى من الله
ان يعيننى ويعلمنى من علمة الواسع فهو ولي ذالك وهو على كل شي قدير

تحياتى وتقدير للجميع  محمود ابوالدهب

اضافة رد جديد اضافة موضوع جديد



المواضيع المتشابهه
عنوان الموضوع الكاتب الردود الزوار آخر رد
ارجو المساعدة فى كود استدعاء من اكثر من شيت ahmed88872
5 79 YasserKhalil
هل يمكن الاستدعاء بشرطين أو أكثر بالتعديل على هذا الكود أبو يوسف النجار
5 1531 تاج الدين
استدعاء بيانات ابوملك زكريا
4 167 ابوملك زكريا
اصلاح معادلات استدعاء بيانات ahmed moh
2 228 ahmed moh
المساعده فى استدعاء بيانات الطلاب saeyd11
13 3140 تاج الدين

الكلمات الدلالية
مراجع ، استدعاء ، وتنسيق ، خلايا ،









اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.

الساعة الآن 12:30 PM