اذهب الي المحتوي
أوفيسنا

الردود الموصى بها

قام بنشر

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

المرجوا المساعدة في اضافة 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

 

  • Like 1

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information