مساعدة في كود لا يقبل إضافة msgbox

[محمد هشام.]

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

المرجوا المساعدة في اضافة msgbox إلى الكود لأني حاولت كثيرا حيث عند اضافة الرسالة يتم عرضها عدد مرات ترحيل الاعمدة يعني يرحل عمود وتظهر الرسالة ولما بضغط ok يكمل الترحيل  وهكذا حتى ينتهي  

عاوز طريقة تخلي الرسالة تظهر مرة واحدة عند نهاية الترحيل فقط 

الكود:

Sub V_ترحيل()
Dim r As Integer
Dim xnewr As Integer
For r = 5 To 650
    Application.ScreenUpdating = False
    If IsEmpty(Cells(r, 1)) Then Exit Sub
    xnewr = Feuil5.Cells(1, 1).CurrentRegion.Rows.Count + 1
    If Cells(r, 1).Value = "" Then Exit Sub
   Feuil5.Cells(xnewr, 1) = Cells(r, 1)
    Feuil5.Cells(xnewr, 2) = Cells(r, 2)
    Feuil5.Cells(xnewr, 3) = Cells(r, 3)
    Feuil5.Cells(xnewr, 4) = Cells(r, 4)
    Feuil5.Cells(xnewr, 5) = Cells(r, 5)
    Feuil5.Cells(xnewr, 6) = Cells(r, 6)
Feuil5.Cells(xnewr, 7) = Cells(r, 7)       Feuil5.Cells(xnewr, 😎 = Cells(r, 😎  
Feuil5.Cells(xnewr, 9) = Cells(r, 9)
    Feuil5.Cells(xnewr, 10) = Cells(r, 10)
    Feuil5.Cells(xnewr, 11) = Cells(r, 11)
    Feuil5.Cells(xnewr, 12) = Cells(r, 12)
    Feuil5.Cells(xnewr, 13) = Cells(r, 13)
    Feuil5.Cells(xnewr, 14) = Cells(r, 14)
    Feuil5.Cells(xnewr, 15) = Cells(r, 15)
    Feuil5.Cells(xnewr, 16) = Cells(r, 16)
    Feuil5.Cells(xnewr, 17) = Cells(r, 17)
    Feuil5.Cells(xnewr, 18) = Cells(r, 18)
    Feuil5.Cells(xnewr, 19) = Cells(r, 19)
    Feuil5.Cells(xnewr, 20) = Cells(r, 20)
    Feuil5.Cells(xnewr, 21) = Cells(r, 21)
    Feuil5.Cells(xnewr, 22) = Cells(r, 22)
    Feuil5.Cells(xnewr, 23) = Cells(r, 23)
    Feuil5.Cells(xnewr, 24) = Cells(r, 24)
    Feuil5.Cells(xnewr, 25) = Cells(r, 25)
    Feuil5.Cells(xnewr, 26) = Cells(r, 26)
    Feuil5.Cells(xnewr, 27) = Cells(r, 27)
    Feuil5.Cells(xnewr, 28) = Cells(r, 28)
Cells(r, 5) = ""
    Cells(r, 6) = ""
    Cells(r, 7) = ""
        Cells(r, 😎 = ""
    Cells(r, 9) = ""
    Cells(r, 10) = ""
    Cells(r, 11) = ""
    Cells(r, 12) = ""
    Cells(r, 13) = ""
    Cells(r, 14) = ""
    Cells(r, 15) = ""
    Cells(r, 16) = ""
    Cells(r, 17) = ""
    Cells(r, 18) = ""
    Cells(r, 19) = ""
    Cells(r, 20) = ""
    Cells(r, 21) = ""
    Cells(r, 22) = ""
    Cells(r, 23) = ""
    Cells(r, 24) = ""
    Cells(r, 25) = ""
    Cells(r, 26) = ""
    Cells(r, 27) = ""
    Cells(r, 28) = ""
Application.ScreenUpdating = True
        Next
           End Sub

 

[محي الدين ابو البشر]

عليكم السلام

ربما

Sub V_ÊÑÍíá()
 
Dim r As Integer
Dim xnewr As Integer
Application.ScreenUpdating = False
For r = 5 To 650
    If IsEmpty(Cells(r, 1)) Then Exit Sub
    xnewr = Feuil5.Cells(1, 1).CurrentRegion.Rows.Count + 1
    If Cells(r, 1).Value = "" Then Exit Sub
    For i = 1 To 28
    Feuil5.Cells(xnewr, i) = Cells(r, i)
        If i >= 5 Then Cells(r, i) = ""
    Next
Next
    Application.ScreenUpdating = True
    MsgBox "Done"
End Sub

 

[محمد هشام.]

شكرا لحضرتك على اهتمامك .لاكن للأسف لا زالت المشكلة قائمة يتم ظهور الرسالة عدد الصفوف المرحلة 

[محي الدين ابو البشر]

هذا مجرب عندي

Sub V()
    Dim r As Integer
    Dim xnewr As Integer
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    For r = 5 To 650
        If IsEmpty(Cells(r, 1)) Then Exit Sub
        xnewr = Feuil5.Cells(1, 1).CurrentRegion.Rows.Count + 1
        If Cells(r, 1).Value = "" Then Exit Sub
        For i = 1 To 28
            Feuil5.Cells(xnewr, i) = Cells(r, i)
            If i >= 5 Then Cells(r, i) = ""
        Next
    Next
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    MsgBox "Done"
End Sub