تنفيذ كود ترحيل على شيتات محميه

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

السلام عليكم

لقد قام الاخ الكريم  والمعلم الكبير ياسر خليل بعمل كود ترحيل ... يتم الترحيل على اساس اسم الشيت والذى مصدره الخليه A3

ولقد قمت بحمايه الشيتات التى يتم الترحيل اليها بكلمه سر 2191612

وعند تنفيذ الكود  ...... لا يتم الترحيل اذا ما كانت الشييتات محمية

ولقد حاولت .... الا ان المحاولات بائت بالفشل .... واظن لان كلمه 

ActiveSheet.Unprotec  يقد بها الشيت الذى اقف فيه ويتم تنفيذ الكود منه 

المراد فك حمايه الشيتات التى يتم الترحيل اليها

()Sub Transfer1
Application.ScreenUpdating = False
  On Error Resume Next
     "ActiveSheet.Unprotect "2191612
    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
    T = WS.Range("A3").Value
    
    Application.ScreenUpdating = False
            If Not IsEmpty(WS.Range("c6")) Then
                Range("B6:G" & LR).Copy
                With Sheets(T)
                    LRT = .Cells(Rows.Count, 3).End(xlUp).Row + 1
                    .Cells(LRT, 2).PasteSpecial xlPasteValues
                End With
            
                Answer = MsgBox("تم ترحل البيانات .....هل تريد أن مسح البيانات المرحلة؟", vbYesNo + vbQuestion)
                If Answer = vbYes Then
                    Sheets("1").Activate
                    Sheets("1").Range("A3,C6:C35,F6:G35").Select
                    Selection.ClearContents
                    Else
      MsgBox "!! لم يتم الحذف"
                 End If
                Sheets("1").Select
    ActiveWindow.SmallScroll Down:=-12
    Range("A3,C6").Select
            Else
                MsgBox "الخلية المحددة فارغة لذا لن يتم تنفيذ الكود": Exit Sub
             End If
            Application.CutCopyMode = False
            Application.ScreenUpdating = True
            "ActiveSheet.Protect "2191612
End Sub

[ياسر خليل أبو البراء]

جرب الكود بهذا الشكل

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
    T = WS.Range("A3").Value

    Application.ScreenUpdating = False
    WS.Unprotect "2191612"
        If Not IsEmpty(WS.Range("c6")) Then
            Range("B6:G" & LR).Copy
            With Sheets(T)
                .Unprotect "2191612"
                LRT = .Cells(Rows.Count, 3).End(xlUp).Row + 1
                .Cells(LRT, 2).PasteSpecial xlPasteValues
                Protect "2191612"
            End With
    
            Answer = MsgBox("تم ترحل البيانات .....هل تريد أن مسح البيانات المرحلة؟", vbYesNo + vbQuestion)
            If Answer = vbYes Then
                Sheets("1").Activate
                Sheets("1").Range("A3,C6:C35,F6:G35").Select
                Selection.ClearContents
            Else
                MsgBox "!! لم يتم الحذف"
            End If
            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

تقبل تحياتي

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

اخى ياسر 

تظهر هذه الرسالع عند تنفيذ الكود

مرفق الصورة

 

[ياسر خليل أبو البراء]

ضع نقطة قبل كلمة Protect

أنا لم أجرب الكود لأنك لم ترفق ملف ..

.Protect "2191612"

أتمنى تكون المشكلة اتحلت

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

اخى ياسر 

بعد ان تم اضافة النقطة كما بينت ...منعت ظهور الرساله

الا ان الترحيل لا يتم

مرفق الملف

Book7.rar

[ياسر خليل أبو البراء]

جرب الكود بهذا الشكل

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
    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("B6:G" & LR).Copy
                .Cells(LRT, 2).PasteSpecial xlPasteValues
                .Protect "2191612"
            End With
    
            Answer = MsgBox("تم ترحل البيانات .....هل تريد أن مسح البيانات المرحلة؟", vbYesNo + vbQuestion)
            If Answer = vbYes Then
                Sheets("1").Activate
                Sheets("1").Range("A3,C6:C35,F6:G35").Select
                Selection.ClearContents
            Else
                MsgBox "!! لم يتم الحذف"
            End If
            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

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

جزاك الله كل الخير اخى الحبيب ياسر

وجعلة الله ميزان حسناتك