فورم (شريط تقدم تثبيت البيانات) جامع للمرونة والسهولة

[أنس دروبي]

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

أخواني الكرام في منتدانا المتميز

كنت منذ فترة بعيدة قد كتبت في المنتدى عن طلب شريط حالة نسخ البيانات بالدرجة المئوية

والحمد بعد تعب في البحث والتعلم وصلت للحل وأرفقه لكم لكي تشاهدو وتتعلمو كيف الطريقة

ماهو شريط الحالة (أو شريط تقدم تثبيت ونسخ البيانات)

تعرفون جميعاً عند نسخ ملف أوتنزيل برنامج ما يظهر لنا شريط الحالة وهو تقدم تثبيت البيانات

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

في الملف المرفق يوجد فورم (شريط تقدم تثبيت او نسخ بيانات) سهل ومرن وقابل للتعديل ووضعه على أي ملف أكسل فقط أتبع الشرح الموجود على الكودات وسوف تعرف كيف يعمل هذا الكود

أترككم مع الملف

أتمنى ان ينال إعجابكم

أخوكم أنس دروبي

للمعلومة هذا أول ملف أعمله على أوفيس 2013

 

شريط تقدم تثبيت ونسخ البيانات.xls

[الـعيدروس]

أولا اشكرك على هذا املف الرائع

اما الشريط اضن انه غير موجود في المرفق

ارجو التوضيح في اي حدث الكود ؟

[يوسف عطا]

لو تكرمت

ممكن نسخة 2003 ؟؟

[أنس دروبي]

أعتذر أخواني على هذا الخطأ تم أرفاق ملف غير الملف المطلوب في المشاركة الأولى

هذا الملف المرفق وهو الصحيح

أعتذر مرة أخرى عن هذا الخطأ

أنس دروبي

شريط تقدم تثبيت ونسخ البيانات.rar

[يوسف عطا]

كيف يمكن أن نضع كود يستغرق بعض الوقت فى هذا الشريط لكى لكى يظهر أثناء عمل الكود ؟؟

مثلاً كود الترحيل هذا

كيف ندمجه فى كود فورم شريط التقدم ؟؟

Sub ترحيل_د2()

Dim Z As Integer, A As Integer, B As Integer, c As Integer

Sheets("24").Range("A11:DZ5000").ClearContents

Sheets("25").Range("A11:DZ5000").ClearContents

Sheets("26").Range("A11:DZ5000").ClearContents

A = 11: B = 11: c = 11

Application.ScreenUpdating = False

For Z = 11 To 5000

If Cells(Z, 1) = "ناجحة و منقولة للصف الثالث" Then

Range("A" & Z).Resize(1, 33).Copy

Sheets("24").Range("A" & A).PasteSpecial xlPasteValues

Application.CutCopyMode = False

A = A + 1

End If

If Cells(Z, 1) = "راسبة و لها حق الإعادة" Then

Range("A" & Z).Resize(1, 33).Copy

Sheets("25").Range("A" & B).PasteSpecial xlPasteValues

Application.CutCopyMode = False

B = B + 1

End If

If Cells(Z, 1) = "راسبة و ليس لها حق الإعادة" Then

Range("A" & Z).Resize(1, 33).Copy

Sheets("26").Range("A" & c).PasteSpecial xlPasteValues

Application.CutCopyMode = False

c = c + 1

End If

Next

For Y = 24 To 26

Sheets(Sheet & Y).[B11] = 1

rrw = Sheets(Sheet & Y).[B3000].End(xlUp).Row

For Each cc In Sheets(Sheet & Y).Range("B12:B" & rrw)

cc.Value = cc.Offset(-1, 0) + 1

Next cc

Next Y

MsgBox ("الحمد لله تـــم ترحيل الطالبات كل إلى شيت نتيجتها طبقاً للإحصاء التالى ")

For x = 24 To 26

Y = Sheets(Sheet & x).[B3000].End(xlUp).Row - 10

mssg = mssg & Chr(10) & Format(Y, "00") & " Students to Sheet : " & x

Next x

MsgBox (" تم ترحيل عدد" & mssg)

Range("A1").Select

Application.ScreenUpdating = True

End Sub

الف شكر

[أنس دروبي]

السلام عليكم اخي يوسف عطا

اخي قد وضعت الكود الذي في المشاركة ولله الحمد ظبط ولكان انت رابط هذا الكود بصفحات في ملفك

فلو سمحت لي ان ترفق لي الملف الاصلي لكي اربط الفورم في الملف

وإذا كان هناك إزعاج لرفع الملف

الطريقة سهلة جداً

في كود الزر الأول (بدء عملية النسخ)

تستطيع ربط ماكرو (الترحيل) بالكود

مثل ماكرو (anas) المربوط في الزر

أرجو أن أكون الطريقة سهلة ومفهومة

أنس دروبي

تم تعديل ديسمبر 19, 2012 بواسطه Creation World

[saad abed]

اخى انس دروبى

انت انسان موهوب وهبك الله الفهم

عمل جميل جدا وشكل جمالى للبرنامج

ننتظر منك عمل كامل

ولقد قرات رد لك بتقول كلما صممت وجدت افكار اخرى لذا جعل لكل برنامج اصدارت واب جريد

اتمنى لك السلامه

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