يرجى المساعدة في تعديل الكود

[Khorsheed Omar]

لدي هذا الكود و يعمل بشكل جيد ساعدني به الأساتذة هنا

يعمل من شيت الطباعة و يرحل المعلومات إلى شيت الأرشيف و يعيد قفل الشيت ما أحتاجه هو أن يبقى يقفل الشيت و لكن أن يبقي الفلترة مسموحة

أرجو المساعدة

هذا هو الكود 

Sub CopyPrintClear()
    Dim wsArchive As Worksheet
    Dim wsPrint As Worksheet
    Dim lastRow As Long
    Dim copyRange As Range
    Dim rowCount As Long
    Dim i As Long
    Dim Password As String
    Password = "KHORSHEED.OMAR.2025"


    ' تعيين الشيتات
    Set wsPrint = ThisWorkbook.Sheets("طباعة")
    Set wsArchive = ThisWorkbook.Sheets("أرشيف")
    
       ' التحقق من الخلايا المطلوبة
    requiredCells = Array("A2", "F2", "F3", "C18")
    isIncomplete = False
    
    For Each cell In requiredCells
        If Trim(wsPrint.Range(cell).Value) = "" Then
            isIncomplete = True
            Exit For
        End If
    Next cell
    
    If isIncomplete Then
        MsgBox "الملف غير كامل. يرجى تعبئة جميع الخلايا المطلوبة.", vbExclamation
        Exit Sub
    End If
    
    ' رسالة تأكيد
    If MsgBox("هل تريد تنفيذ العملية؟", vbYesNo + vbQuestion, "تأكيد") = vbNo Then
        Exit Sub
    End If


    wsArchive.Unprotect Password:=Password

    ' تحديد نطاق النسخ
    Set copyRange = wsPrint.Range("A6:G15")
    rowCount = copyRange.Rows.Count

    ' تحديد أول صف فارغ في شيت الأرشيف
    lastRow = wsArchive.Cells(wsArchive.Rows.Count, "B").End(xlUp).Row + 1

    ' نسخ الجدول بالكامل إلى الأرشيف
    wsArchive.Range("A" & lastRow).Resize(rowCount, 5).Value = copyRange.Value

    ' نسخ C18 إلى العمود F في كل صف من الصفوف المنسوخة
    wsArchive.Range("F" & lastRow & ":F" & lastRow + rowCount - 1).Value = wsPrint.Range("C18").Value

    ' نسخ B3 إلى العمود J في كل صف من الصفوف المنسوخة
    wsArchive.Range("J" & lastRow & ":J" & lastRow + rowCount - 1).Value = wsPrint.Range("B3").Value
    
    ' نسخ F3 إلى العمود H في كل صف من الصفوف المنسوخة
    wsArchive.Range("H" & lastRow & ":H" & lastRow + rowCount - 1).Value = wsPrint.Range("F3").Value
    
   ' نسخ F2 إلى العمود G في كل صف من الصفوف المنسوخة
    wsArchive.Range("G" & lastRow & ":G" & lastRow + rowCount - 1).Value = wsPrint.Range("F2").Value
    
    ' نسخ A2 إلى العمود I في كل صف من الصفوف المنسوخة
    wsArchive.Range("I" & lastRow & ":I" & lastRow + rowCount - 1).Value = wsPrint.Range("A2").Value
    

    ' تحديد منطقة الطباعة
    wsPrint.PageSetup.PrintArea = "$A$1:$F$18"
    wsPrint.PrintOut

    ' مسح البيانات من A6:A15 و C6:F15
    wsPrint.Range("A6:A15").ClearContents
    wsPrint.Range("C6:E15").ClearContents
    wsPrint.Range("A2").ClearContents
    wsPrint.Range("F2").ClearContents
    wsPrint.Range("F3").ClearContents
    wsPrint.Range("C18").ClearContents
    
    wsPrint.PageSetup.PrintArea = "$A$1:$F$18"
    wsPrint.PrintOut
    wsArchive.Protect Password:=Password, USERINTERFACEONLY:=True
    
    
    ' تنظيف الحافظة
    Application.CutCopyMode = False

    ' العودة إلى شيت الطباعة وتحديد الخلية A1
    wsPrint.Activate
    wsPrint.Range("A1").Select
End Sub

 

تم تعديل منذ 5 ساعات بواسطه Foksh
استخدم الرمز <> في شريط خصائص لكتابة الأكواد

[عبدالله بشير عبدالله]

السلام عليكم

 جرب التعديل التالي

التعديل في الجزء 

    wsArchive.Protect Password:=Password, USERINTERFACEONLY:=True

الى

wsArchive.Protect Password:=Password, USERINTERFACEONLY:=True, AllowFiltering:=True

الكود كاملا

Sub CopyPrintClear()
    Dim wsArchive As Worksheet
    Dim wsPrint As Worksheet
    Dim lastRow As Long
    Dim copyRange As Range
    Dim rowCount As Long
    Dim i As Long
    Dim Password As String
    Dim requiredCells As Variant
    Dim cell As Variant
    Dim isIncomplete As Boolean
    
    Password = "KHORSHEED.OMAR.2025"

    ' تعيين الشيتات
    Set wsPrint = ThisWorkbook.Sheets("طباعة")
    Set wsArchive = ThisWorkbook.Sheets("أرشيف")
    
    ' التحقق من الخلايا المطلوبة
    requiredCells = Array("A2", "F2", "F3", "C18")
    isIncomplete = False
    
    For Each cell In requiredCells
        If Trim(wsPrint.Range(cell).Value) = "" Then
            isIncomplete = True
            Exit For
        End If
    Next cell
    
    If isIncomplete Then
        MsgBox "الملف غير كامل. يرجى تعبئة جميع الخلايا المطلوبة.", vbExclamation
        Exit Sub
    End If
    
    ' رسالة تأكيد
    If MsgBox("هل تريد تنفيذ العملية؟", vbYesNo + vbQuestion, "تأكيد") = vbNo Then
        Exit Sub
    End If

    ' رفع الحماية مؤقتًا
    wsArchive.Unprotect Password:=Password

    ' تحديد نطاق النسخ
    Set copyRange = wsPrint.Range("A6:G15")
    rowCount = copyRange.Rows.Count

    ' تحديد أول صف فارغ في شيت الأرشيف
    lastRow = wsArchive.Cells(wsArchive.Rows.Count, "B").End(xlUp).Row + 1

    ' نسخ الجدول بالكامل إلى الأرشيف
    wsArchive.Range("A" & lastRow).Resize(rowCount, 5).Value = copyRange.Value

    ' نسخ القيم الفردية إلى الأعمدة المطلوبة
    wsArchive.Range("F" & lastRow & ":F" & lastRow + rowCount - 1).Value = wsPrint.Range("C18").Value
    wsArchive.Range("J" & lastRow & ":J" & lastRow + rowCount - 1).Value = wsPrint.Range("B3").Value
    wsArchive.Range("H" & lastRow & ":H" & lastRow + rowCount - 1).Value = wsPrint.Range("F3").Value
    wsArchive.Range("G" & lastRow & ":G" & lastRow + rowCount - 1).Value = wsPrint.Range("F2").Value
    wsArchive.Range("I" & lastRow & ":I" & lastRow + rowCount - 1).Value = wsPrint.Range("A2").Value

    ' تحديد منطقة الطباعة وشطبها
    wsPrint.PageSetup.PrintArea = "$A$1:$F$18"
    wsPrint.PrintOut

    ' مسح البيانات من الشيت
    wsPrint.Range("A6:A15").ClearContents
    wsPrint.Range("C6:E15").ClearContents
    wsPrint.Range("A2").ClearContents
    wsPrint.Range("F2").ClearContents
    wsPrint.Range("F3").ClearContents
    wsPrint.Range("C18").ClearContents

    ' الطباعة مرة ثانية إذا رغبت
    wsPrint.PageSetup.PrintArea = "$A$1:$F$18"
    wsPrint.PrintOut

   
    wsArchive.Protect Password:=Password, USERINTERFACEONLY:=True, AllowFiltering:=True

    ' تنظيف الحافظة
    Application.CutCopyMode = False

    ' العودة إلى شيت الطباعة وتحديد الخلية A1
    wsPrint.Activate
    wsPrint.Range("A1").Select
End Sub