السلام عليكم ورحمة الله وبركاته

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



بفرض أن لديك مجموعة أوراق عمل وتحتوي بعض أوراق العمل على معادلات ، وأردت على سبيل المثال تصدير ورقتي عمل من المصنف الحالي (ورقة العمل Main وورقة العمل Search) ، يمكنك تحديد ورقة العمل Main ثم الضغط على مفتاح Ctrl من لوحة المفاتيح ثم تحديد ورقة العمل Search ، ثم اضغط Alt + F8 من لوحة المفاتيح واختر الإجراء الفرعي المسمى Export_Selected_Sheets ثم انقر الأمر Run ليتم تصدير ورقتي العمل اللتين قمت بتحديدهما إلى مصنف جديد باسم Exported في نفس مسار المصنف الحالي.

وأخيراً إليكم الكود ويوضع في موديول عادي :

Sub Export_Selected_Sheets()
    Dim ws                  As Worksheet
    Dim arrSheetToCopy()    As String
    Dim n                   As Long
    Dim i                   As Long

    If MsgBox("Export Selected Sheets To New Workbook", vbYesNo, "NewCopy") = vbNo Then Exit Sub

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
        n = 0
        For Each ws In ActiveWindow.SelectedSheets
            ReDim Preserve arrSheetToCopy(n)
            arrSheetToCopy(n) = ws.Name
            n = n + 1
        Next ws
        ThisWorkbook.Sheets(arrSheetToCopy(0)).Select
    
        With Workbooks.Add
            For i = (.Sheets.Count + 1) To (UBound(arrSheetToCopy) + 1)
                .Sheets.Add
            Next i
    
            For i = 0 To UBound(arrSheetToCopy)
                ThisWorkbook.Sheets(arrSheetToCopy(i)).Cells.Copy
                With .Sheets(i + 1)
                    .Cells.PasteSpecial xlPasteAll
                    .UsedRange.Value = .UsedRange.Value
                    .Name = ThisWorkbook.Sheets(arrSheetToCopy(i)).Name
                    .DisplayRightToLeft = False
                    .Select: .Range("A1").Select
                End With
            Next i
    
            .SaveAs ThisWorkbook.Path & "Exported.xlsm", xlOpenXMLWorkbookMacroEnabled
            .Close
        End With
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

    MsgBox "Done...", 64
End Sub

رابط الملف من هنا

إعداد وتقديم / ياسر خليل أبو البراء