كود ترحيل

[houari-edu]

الرجاء من الزملاء وضع كود ترحيل بيانات لقدلاحذفت الماكرو بالخطأ و شكرا

ابتدائي2020.xlsm

[MAHMOUD ALI YOUSSEF]

 

[ابراهيم الحداد]

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

تم تعديل الكود

Sub ALIDROOS_JC_T()
Application.ScreenUpdating = False
Dim sh As Worksheet, ws As Worksheet
Set ws = Sheets("معلومات")
On Error GoTo 0
For Each sh In ThisWorkbook.Worksheets
For r = 2 To 102
   If ws.Cells(r, 7).Value <> Empty Then
    If ws.Cells(r, 7).Value = sh.Name Then
      ws.Range(ws.Cells(r, 1), ws.Cells(r, 12)).Copy
      QQ = sh.Cells(1000, 1).End(xlUp).Row + 1
      sh.Range("A" & QQ).PasteSpecial xlPasteValues
      End If
     End If
       Next
        Next
 MsgBox "تم الترحيل بنجاح"
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[houari-edu]

لقد نسخت الكود لكن لا يعمل معي أرجو وضع الكود في الملف المرفق و شكرا

[ابراهيم الحداد]

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

اليك الملف

ابتدائي2020.xlsm

[houari-edu]

شكرا أستاذنا جعله الله في ميزان حسناتك