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

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