نسخ ملف اكسيل كما هو بدون معادلات او اكواد - محتوى البيانات فقط

[Hesham.Abusna]

السادة زملاء و اعضاء المنتدى . عيد اضحى مبارك .. 

** - المعطيات // لدي ملف اكسيل به اكثر 20 شيت بالمعادلات و الاكواد . 

السؤال / اريد ارسال الملف و نسخه الى طرف آخر كما هو بكافة التنسيقات على الملف ))) بدون المعادلات و الاكواد - دفعة واحدة و ليس - شيت شيت (((

هل من سبيل لذلك .. 

مشكور جدا .

 

 

تم تعديل منذ 14 ساعات بواسطه Hesham.Abusna

[محمد هشام.]

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

يمكنك تعديل هدا بما يناسبك 

Option Explicit
Sub Sauvegarde_WB()
  Dim WS As Worksheet, CrWS As Workbook, newWs As Worksheet, f As Worksheet
  Dim chemin$, sNom$, dossier$, sPath$, n As Boolean

    On Error GoTo EndClear
    SetApp False
    Set CrWS = Workbooks.Add(xlWBATWorksheet)
    Set f = CrWS.Sheets(1): f.Name = "Temp"
    n = True
    For Each WS In ThisWorkbook.Worksheets
        WS.Copy After:=CrWS.Sheets(CrWS.Sheets.Count)
        Set newWs = CrWS.Sheets(CrWS.Sheets.Count)
        newWs.UsedRange.Value = newWs.UsedRange.Value
         On Error Resume Next: newWs.Buttons(1).Delete: On Error GoTo 0
        newWs.Name = Left(WS.Name, 31)
        If n Then: f.Delete: n = False
    Next WS
    dossier = ThisWorkbook.Path & "\Workbook_Copy"
    If Dir(dossier, vbDirectory) = "" Then MkDir dossier
    sPath = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1)
    sNom = sPath & "_" & Format(Now, "dd-mm-yyyy") & ".xlsx"
    chemin = dossier & "\" & sNom
    CrWS.SaveAs Filename:=chemin, FileFormat:=xlOpenXMLWorkbook
    CrWS.Close False
    SetApp True
    Exit Sub
EndClear:
    SetApp True
End Sub
Private Sub SetApp(ByVal enable As Boolean)
    With Application
        .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable
        .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual)
    End With
End Sub

 

TEST.xlsb

[Hesham.Abusna]

8 ساعات مضت, محمد هشام. said:

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

يمكنك تعديل هدا بما يناسبك 

Option Explicit
Sub Sauvegarde_WB()
  Dim WS As Worksheet, CrWS As Workbook, newWs As Worksheet, f As Worksheet
  Dim chemin$, sNom$, dossier$, sPath$, n As Boolean

    On Error GoTo EndClear
    SetApp False
    Set CrWS = Workbooks.Add(xlWBATWorksheet)
    Set f = CrWS.Sheets(1): f.Name = "Temp"
    n = True
    For Each WS In ThisWorkbook.Worksheets
        WS.Copy After:=CrWS.Sheets(CrWS.Sheets.Count)
        Set newWs = CrWS.Sheets(CrWS.Sheets.Count)
        newWs.UsedRange.Value = newWs.UsedRange.Value
         On Error Resume Next: newWs.Buttons(1).Delete: On Error GoTo 0
        newWs.Name = Left(WS.Name, 31)
        If n Then: f.Delete: n = False
    Next WS
    dossier = ThisWorkbook.Path & "\Workbook_Copy"
    If Dir(dossier, vbDirectory) = "" Then MkDir dossier
    sPath = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1)
    sNom = sPath & "_" & Format(Now, "dd-mm-yyyy") & ".xlsx"
    chemin = dossier & "\" & sNom
    CrWS.SaveAs Filename:=chemin, FileFormat:=xlOpenXMLWorkbook
    CrWS.Close False
    SetApp True
    Exit Sub
EndClear:
    SetApp True
End Sub
Private Sub SetApp(ByVal enable As Boolean)
    With Application
        .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable
        .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual)
    End With
End Sub

 

TEST.xlsb 39.5 kB · 1 download

شكرا جدا . اهتمامك استاذنا العبقري .. استاذ محمد هشام 

استأذنك الكود المرسل . هل يدرج في حدث كل شيت . حاولت تجربته في شيت آخر و تم حفظه بصيغة الماكرو و لم يعمل 

هل ممكن تجربة تطبيقه على الملف المرسل من سيادتك . كمثال 

تم تعديل منذ 2 ساعات بواسطه Hesham.Abusna

[Foksh]

مشاركة بتوضيح فكرة الأستاذ @محمد هشام. مشكوراً على فكرته الجميلة ..

1. انسخ الدالة السابقة الى مديول جديد في مشروعك الرئيسي واحفظه .

2. تستطيع تشغيل الماكرو بالنقر على Alt + F8 ، ثم تختار اسم الماكرو ، وانقر زر تشيل Run .

3. سيتم إنشاء مجلد جديد حسب الكود ( Workbook_Copy ) . وبداخله نسخة من مشروعك الأصلي لا تحتوي معادلات أو أزرار أو أكواد ... الخ .

 

💡 والتوظيف الذكي في الكود ، أن النسخة الناتجة لا تدعم الماكرو حتى لو حاولت إعادة تضمينها ، انظر السطر :-

xlOpenXMLWorkbook  ' أي .xlsx

أي أنه لم يستخدم فكرة استنساخ الملف الجديد عن الأصل بنفس الإمتداد .

ودمتم بخير جميعاً