السلام عليكم ...توقف عمل كود الترحيل وكذلك توقف كود طباعه الجزء المحدد في حال كانت الصفحة محمية.
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