اضافة على كود ترحيل الاخ ياسر خليل

[۩◊۩ أبو حنين ۩◊۩]

السلام عليكم

ارجو المساعده فى اضافه على كود للاخ الفاضل ياسر حليل

 

الكود يقوم بالترحيل الى اسم الشيت المتواجد فى الخليه A3

المطلوب

بلاضافه ان الكود بقوم بالترحيل الى اسم الشيت فى الخليه A3 اريد لن  يتم الترحيل ايضا الى الشيت المسمى general

اى لو محتوى الخليه   A3  هو Medi. Kha  يتم الترحيل الى شيت Medi. Kha  وشيت general فى نفس الوقت

او بتم الترحيل الى محتوى الخليه A3  والخليه D3

 

 

 

 Sub Transfer()

  Application.ScreenUpdating = False

    On Error Resume Next

    Dim Cell As Range, T As String, LR As Long, LRT As Long

    Dim WS As Worksheet, Answer As Long

    Set WS = Sheets("1")

    LR = WS.Cells(35, 3).End(xlUp).Row

    nR = 6

10   If Cells(nR, "H").Value = "تم الترحيل" Then nR = nR + 1: GoTo 10

    If nR > LR Then MsgBox "لن يتم الترحيل : برجاء ضبط العمود إتش": Exit Sub

    T = WS.Range("A3").Value

   

    Application.ScreenUpdating = False

    WS.Unprotect "2191612"

        If Not IsEmpty(WS.Range("C6")) Then

            With Sheets(T)

                .Unprotect "2191612"

                LRT = .Cells(Rows.Count, 3).End(xlUp).Row + 1

                WS.Range("B" & nR & ":G" & LR).Copy

                .Cells(LRT, 2).PasteSpecial xlPasteValues

                .Protect "2191612"

             End With

            WS.[H6].Value = "تم الترحيل"

            WS.Range("H6:H" & LR).FillDown

            Sheets("1").Select

            ActiveWindow.SmallScroll Down:=-12

            Range("A3,C6").Select

        Else

            MsgBox "الخلية المحددة فارغة لذا لن يتم تنفيذ الكود": Exit Sub

        End If

    WS.Protect "2191612"

    Application.CutCopyMode = False

    Application.ScreenUpdating = True

End Sub

[۩◊۩ أبو حنين ۩◊۩]

للرفع 

[۩◊۩ أبو حنين ۩◊۩]

للرفع

الكود بقوم بالترحيل الى الشيت الذى اسمه  فى الخليه A3 اريد لن يتم الترحيل ايضا  الى الشيت الذى اسمه موجود فى الخلية A3 بلاضافه الى شيت general

تم تعديل يونيو 25, 2015 بواسطه ۩◊۩ أبو حنين ۩◊۩