هل ممكن عمل بروجرس بار لكود الترحيل المرفقPROGRESS BAR

[أيسم إبراهيم]

السلام عليكم جميعا

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

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

وبعض الشرح إن أمكن

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

مرفق ملف

_______________.rar

[نزار سليمان عيد]

السلام عليكم

فضلا انظر للمرفق

مع الشكر

ابو خالد

______________3.rar

[ابو اسامة العينبوسي]

السلام عليكنم

مشكور اخ نزار على الحل

انا اضفت سطر لكود الاخ خبور وهو :

Application.Calculation = xlCalculationManual

انسخ الكود و انظر الفرق في السرعة

Sub Khcontrol()
On Error Resume Next
Dim MyRange As Range
Dim Studcount As Integer, SheetCount As Integer, StusentsNum As Integer
Dim CmNO As Integer, RowsUp As Integer, RowsDown As Integer
Dim A As Integer, B As Integer, C As Integer, D As Integer, E As Integer
Dim F As Integer, G As Integer, H As Integer, K As Integer
Set KhAppli = Application.WorksheetFunction
Set MyRange = Range("ÇáÈíÇäÇÊ")
StusentsNum = KhForSheet.TextBox1.Value
With MyRange
    Studcount = KhAppli.CountA(.Range("A1:A" & .Rows.Count))
End With
SheetCount = KhAppli.RoundUp(Studcount / StusentsNum, 0)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'===============================
'ãÓÍ ÇáãÍÊæíÇÊ
With æÑÞÉ2
    .Cells.Clear
End With
'===============================
'äÞá ÇáÈíÇäÇÊ ÈßæÏ ãä ÇßæÇÏ ÈÑäÇãÌ ÎÈæÑÇáãÏÑÓí
With æÑÞÉ2
RowsUp = KhForSheet.TextBox2.Value
RowsDown = KhForSheet.TextBox3.Value
CmNO = KhForSheet.TextBox4.Value
A = RowsUp
B = 0
For C = 1 To SheetCount
    For D = 1 To StusentsNum
        For E = 1 To CmNO
            F = D + A
            G = D + B
            .Cells(F, E) = MyRange.Cells(G, E)
        Next E
    Next D
    A = A + StusentsNum + RowsUp + RowsDown
    B = B + StusentsNum
Next C
End With
'===============================
'äÓÎ ÑÄæÓ ÇáÇÚãÏÉ
With æÑÞÉ2
    Range(Cells(MyRange.Row - RowsUp, 1), Cells(MyRange.Row - 1, CmNO)).Copy
    H = 1
    For K = 1 To SheetCount
        .Cells(H, 1).PasteSpecial
        H = H + StusentsNum + RowsUp + RowsDown
    Next K
    .Select
End With
Application.CutCopyMode = False
'===============================
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Êã ÇÓÊÏÚÇÁ ÇáßÔæÝÇÊ ÚÏÏ " & SheetCount & " ÈäÌÇÍ ", 524288 + 1048576, "ÊÃßíÏ ÇáÇÓÊÏÚÇÁ"
Range("A1").Select
End
On Error GoTo 0
End Sub

[ابو اسامة العينبوسي]

السلام عليكم

بعد تعديل الكود ليكون اسرع

وهو يخص موضوع حساب الخلايا

______________4.rar

______________4.rar

[أيسم إبراهيم]

السلام عليكم

الأساتذة الكرام

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

الأستاذ : نزار ما شاء الله عليك مبدع دائما . هذا ما أردت و أفضل مما تخيلت. شكرااااااااااااااااااااااااااااااااااااااااا

الأستاذ أبو أسامه

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

لى طلب آخر أرجو أن يتسع صدركم له

هل ممكن التعديل بحيث يقوم الكود بنسخ بعض التنسيقات (( الأسطر "" 8 أسطر "" التي يكون بها التذييل يتم تحديدها بمعرفتكم )) في تذييل كل صفحة جديدة كما هو الحال في نسخ رأس كل صفحة المعمول به في الكود الحالي؟؟؟؟؟؟؟؟؟؟؟

جزاكم الله خيرا و جعله في ميزان حسناتكم مثاقيل كثيرة.

[أيسم إبراهيم]

للرفع

للرفع

للرفع

رفع الله قدركم درجات في الجنة