عبد الفتاح كيرة

تفضل أخى Private Sub Worksheet_Activate() Dim myrng As Range Dim mycl As Range Set myrng = Range("b2:b10000") On Error GoTo 1 For Each mycl In myrng mycl.Value = WorksheetFunction.VLookup(mycl.Offset(0, -1).Value, Sheets("ãÎÒä").Range("a:b"), 2, 0) Next mycl 1 End Sub لكن حبذا لو قللت نهاية المدى عن 10000 حتى لا يكون الكود بطيئا المرفقات المخازن1kemas.zip

العبرة بوقت التنفيذ وقد جربته ووجدته يعمل بصورة عادية

الأخ الأستاذ الفاضل سعد أنا ممنون جدا لك و لكلامك الطيب و ثنائك العطر وفقك الله لكل خير وبارك فيك

تفضل أخى Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column <> 2 Or Target.Row <> 5 Then Exit Sub If Range("b5") = vbNullString Then Range("c5: e5") = "" Exit Sub End If Range("c5") = WorksheetFunction.VLookup(Range("B5"), Sheets(1).Range("A6:D10"), 2, 0) Range("d5") = WorksheetFunction.VLookup(Range("B5"), Sheets(1).Range("A6:D10"), 3, 0) Range("e5") = WorksheetFunction.VLookup(Range("B5"), Sheets(1).Range("A6:D10"), 4, 0) End Sub vlookup- kemas.zip

أخى الأستاذ جلال أعرف أن هذا العمل يهمك من الأفضل أن تعدل فيه بنفسك على ما تريد كى تزيد استفادتك وهذه نسخة جديدة من الملف يتم فيها حذف أسطر زائدة نهاية الشيت الترحيل بالفلترة - ترويسة و تذييل بالكود -- فواصل.zip

بالنسبة للطلب الأول وهو ما سمح به وقتى الآن وهو بطء البرنامج فلم ألحظ أى بطء لعل السبب من الجهاز أما الطلب الثانى فيحتاج لوقت لكن يمكنك مراجعة سطور الكود الخاصة بزر الحساب مرة أخرى

السلام عليكم أشكر جميع من قاموا بالرد جزاكم الله خيرا أستاذى و معلمى الحسامى شهادة أعتز بها أستاذى أبو أحمد جزاك الله خبرا أستاذى khhanna شكرا لثنائك الطيب أستاذى الحبيب " الجزيرة " بوركت و شكرا لتعليقك الطيب جزاكم الله خيرا جميعا

السلام عليكم هذا ملف يتم فيه المذكور بالعنوان فهذه صورة البيانات قبل الفلترة وهذه صفحة الترحيل و تظهر فيها الديباجة العليا مع التذييل كل كشف عبارة عن 20 اسما أتمنى أن يفيدكم الترحيل بالفلترة - ترويسة و تذييل بالكود - فواصل.zip

معادلة ذكية أخانا بن علية

مرحبا بالإبداعات زادك الله علما وبارك فيك

أستاذ جلال إذا كان الملف لا يعمل معك لظروف غامضة جرب الملف فى المشاركة رقم 6

ممتاز شكرا أستاذنا الحسامى

جزاك الله خيرا

Columns("F:F").Select Range("F3").Activate Selection.ColumnWidth = 23 Columns("F:F").Select With Selection .WrapText = False .Orientation = 0 .AddIndent = False .ShrinkToFit = True .ReadingOrder = xlContext .MergeCells = False End With With Selection .WrapText = True .Orientation = 0 .AddIndent = False .ShrinkToFit = True .ReadingOrder = xlContext .MergeCells = False End With End Sub test-kemas.rar

تقبل شكرى لك أخى أبا العقاب بارك الله فيك

ما مصدر التكرار ؟ من أين تأخذ الليست بوكس هذه القيم

الأخ galal_mk هذا تعديل للكود بحيث يسمح بإضافة العناوين العلوية و الترويسة السفلية و الأخ ايمن حسن حولنا الكود إلى وظيفة يتم استدعاؤها بكلمة ناجح أو كلمة راسب لابد أن يكون اسم الشيت أيضا ناجح و راسب تفضلوا الترحيل بالفلترة - ترويسة و تذييل بالكود.zip

نشكرك أخانا الحسامى على هداياك الرائعة

أشكرك أستاذ معتصم جزاك الله خيرا صاحب المدونة الجميلة

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

ما الأعمدة وما الديباجة بعدها مزيد من الوقت إن شاء الله

أهلا و سهلا بك أخى بيننا و إن شاء الله تفيد و تستفيد بارك الله فيك

تفضل عصام NEW_PROGRAM-kemas.zip

مؤقتا هذا حل بدون معادلات وبدون أكواد مجرد تعديل فى خصائص مربع التحرير و السرد masterkey-KEMAS2.zip

تفضل بالمرفقات masterkey-KEMAS.zip