وعليكم السلام-يمكنك تطويع هذا الكود
Option Explicit
Option Base 1
Sub Wsh_CopyTo_NewWbk()
Dim aWsh As Variant
aWsh = [{"Sheet1","Wsh1";"Sheet2","Wsh2"}]
Dim aWshSrc(2) As Worksheet
Dim wbk As Workbook, wsh As Worksheet
Dim vItm As Variant, b As Byte
Rem Set Worksheet Array
With ThisWorkbook
For b = 1 To UBound(aWsh)
.Worksheets(aWsh(b, 1)).Unprotect Password:=aWsh(b, 2)
Set aWshSrc(b) = .Worksheets(aWsh(b, 1))
Next: End With
Rem Add New Workbook
Set wbk = Workbooks.Add
With wbk
Rem Delete All Worksheets but One
Application.DisplayAlerts = False
For Each wsh In .Worksheets
With wsh
If .Index = 1 Then .Name = "!DELETE" Else .Delete
End With: Next
Application.DisplayAlerts = True
Rem Copy Worksheets
For Each vItm In aWshSrc
vItm.Copy After:=Sheets(.Sheets.Count)
Set wsh = .Sheets(.Sheets.Count)
wsh.UsedRange.Value = wsh.UsedRange.Value2
Next
Rem Delete Reamining Worksheet
Application.DisplayAlerts = False
.Worksheets("!DELETE").Delete
Application.DisplayAlerts = True
End With
End Sub