تعديل كود لتصدير البيانات بدون معادلات

[a.kawkab]

اساتذة المنتدى الكرام

مطلوب تعديل الكود التالى بحيت يتم تصدير البيانات بدون معادلات

Sub Export_Specific_Sheets_To_One_Workbook_Using_Arrays()
    Dim ws          As Worksheet
    Dim sSheets()   As String
    Dim n           As Long

    Application.ScreenUpdating = False
        For Each ws In Worksheets(Array("تقارير الانسولين", "تقرير الأصناف", "تقارير التكلفة" _
      , "تقارير الريبافيرين والms", "هرمون النمو والثلاثيميا", "التذاكر الطبية"))
         
  
            n = n + 1
            ReDim Preserve sSheets(1 To n)
            sSheets(n) = ws.Name
        Next ws
    
        Worksheets(sSheets).Copy
        Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\Output", FileFormat:=51
        Application.DisplayAlerts = True
    
        For Each ws In ActiveWorkbook.Worksheets
            ws.UsedRange.Value = ws.UsedRange.Value
        Next ws
    
        ActiveWorkbook.Close True
    Application.ScreenUpdating = True
    
    MsgBox "Done...", 64
End Sub

 

 

[a.kawkab]

Sub Export_Specific_Sheets_To_One_Workbook_Using_Arrays()
    Dim ws          As Worksheet
    Dim sSheets()   As String
    Dim n           As Long

    Application.ScreenUpdating = False
    For Each ws In Worksheets(Array("تقاريرانسولين الهيئة", "تقارير انسولين الطلاب والرضع", "تقارير الاصناف"))
  
            n = n + 1
            ReDim Preserve sSheets(1 To n)
            sSheets(n) = ws.Name
        Next ws
    
        Worksheets(sSheets).Copy
        Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\Output", FileFormat:=51
        Application.DisplayAlerts = True
    
        For Each ws In ActiveWorkbook.Worksheets
            ws.UsedRange.Value = ws.UsedRange.Value
        Next ws
    
        ActiveWorkbook.Close True
    Application.ScreenUpdating = True
    
    MsgBox "Done...", 64
End Sub

الكود السابق يقوم بتصدير الشيتات المحددة الى شيت منفصل بدون اظهار المعادلات لكن عندما اقوم بحماية شيتات التقارير يرفض التصدير الا فى حالتين الاولى ان الغى الحمايه وهى ضروريهلعدم العبث فى المعادلات وبالتالى يحدث احطاء فى التفارير الثانية تعطيل الجزء  ws.UsedRange.Value = ws.UsedRange.Value من الماكرو وفى هذه الحالة يتم تصدير التقارير مع المعادلات والمطلوب التصدير بدون معادلات اى قيم فقط مرفق صور توضيحية للمشكلة بالاضافة لملف العمل وكود الغاء الحماية123

 

التقارير.xlsm

[a.kawkab]

ارجو من الاساتذة الافاضل ان يكون لدى احدهم حل للمطلوب

التقارير.xlsm

[a.kawkab]

Sub Export_Specific_Sheets_To_One_Workbook_Using_Arrays()
    Dim ws          As Worksheet
    Dim sSheets()   As String
    Dim n           As Long

    Application.ScreenUpdating = False

    For Each ws In Worksheets(Array("انسولين الهيئة", "انسولين الطلاب والرضع", "تقارير الاصناف"))
  
            n = n + 1
            ReDim Preserve sSheets(1 To n)
            sSheets(n) = ws.Name
        Next ws
    
        Worksheets(sSheets).Copy
        Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\Output", FileFormat:=51
        Application.DisplayAlerts = True
'
'        For Each ws In ActiveWorkbook.Worksheets
'            ws.UsedRange.Value = ws.UsedRange.Value
'        Next ws
    For Each ws In ActiveWorkbook.Worksheets
            ws.Unprotect 123
                ws.UsedRange.Value = ws.UsedRange.Value
            ws.Protect 123
        Next ws
        ActiveWorkbook.Close True

    Application.ScreenUpdating = True
    
    MsgBox "Done...", 64
End Sub

 

تم تعديلالكود بواسطة الاستاذ ياسر خليل جزاه الله خيرا وتم المطلوب والحمد لله

وهذا الجزء هو ماتم تعديله

 For Each ws In ActiveWorkbook.Worksheets
            ws.Unprotect 123
                ws.UsedRange.Value = ws.UsedRange.Value
            ws.Protect 123
        Next ws