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

كود ترحيل


إذهب إلى أفضل إجابة Solved by ابراهيم الحداد,

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

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

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

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

 

  • Like 2
رابط هذا التعليق
شارك

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