خطا في كود طباعه الجزء المحدد وفي كود الترحيل في حال كانت الاوراق محمية

ابو طيبه · أبريل 1, 2020

Sub Print_Selection()
'
Dim Cel As Range
Dim Rng As Range
Dim Del_Rng As Range

ScreenOff
Return_Sh = ActiveSheet.Name
ActiveSheet.Copy after:=Sheets(Sheets.Count)
ActiveSheet.UsedRange.Borders.LineStyle = xlNone
'===============================================================
Set Rng = Selection
Rng.Interior.ColorIndex = 4
Set SourceRange = ActiveSheet.Cells
Set destrange = ActiveSheet.Cells
SourceRange.Copy
destrange.PasteSpecial (xlValues)
Application.CutCopyMode = False
'===============================================================
For Each Cel In ActiveSheet.UsedRange
    If Cel.Interior.ColorIndex <> 4 Then
        If Del_Rng Is Nothing Then
            Set Del_Rng = Cel
        Else
            Set Del_Rng = Application.Union(Del_Rng, Cel)
        End If
    End If
Next
Del_Rng = ""
ActiveSheet.UsedRange.Interior.ColorIndex = xlNone
'===============================================================
For Each shp In ActiveSheet.Shapes
        shp.Delete

Next shp
'===============================================================
ActiveSheet.PrintOut
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
Sheets(Return_Sh).Select
'===============================================================
ScreenOn
Set Cel = Nothing
Set Del_Rng = Nothing
'
End Sub

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

تحياتي للجميع

Sub ترحيل()
Dim lastRow As Integer, WS As Worksheet, SH As Worksheet
Set WS = ThisWorkbook.Worksheets("قائمة"): Set SH = ThisWorkbook.Worksheets("اسماءالمراجعين")
lastRow = WS.Cells(Rows.Count, 2).End(xlUp).Row
With SH: lr = SH.Cells(Rows.Count, 2).End(xlUp).Row + 1
    With .Range("B" & lr): .NumberFormat = "[$-,101]yyyy/mm/dd;@": .Value = Date: .Cells(, 1).Resize(ColumnSize:=4).Merge
    With .Cells(, 1).Resize(ColumnSize:=4): .Borders.Value = 1: .Borders.Weight = xlMedium: .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter: .Font.Bold = True: .Font.ColorIndex = xlAutomatic: .Interior.ThemeColor = xlThemeColorDark1: .Interior.TintAndShade = -0.349986266670736: End With: End With
End With
WS.Range("b2:e" & lastRow).Copy
SH.Range("b" & lr + 1).PasteSpecial Paste:=xlPasteValues
WS.Range("b2:b" & Rows.Count).ClearContents
MsgBox "لقد تم ترحيل البيانات بنجاح"
End Sub