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

[Hesham.Abusna]

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

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

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

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

مشكور جدا .

 

 

تم تعديل بالامس في 19:19 بواسطه 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

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

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

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

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

[Foksh]

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

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

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

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

 

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

xlOpenXMLWorkbook  ' أي .xlsx

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

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

[Hesham.Abusna]

تمام جدا .. تمت التجربة بنجاح .. جزيل الشكر و العرفان لاستاذنا العبقري / محمد هشام. 

شكرا لاهتمامك بكل الزملاء و استجابتك السريعة .. جزيل الشكر  كونك دائما رمزا للعطاء اعزك الله وحفظك و يبارك في عمرك وعملك .💚

شكرا للاستاذ المحترم / Foksh . على توضيحه . شكرا لكل القائمين على اعرق منتدى في الوطن العربي .. تحياتي لكم جميعا .. دمتم في صحة و عافية ..  

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

[Foksh]

أشكرك على ثقتك أخي الكريم ، ولكن صاحب الكود الأستاذ @محمد هشام. . لذا هو صاحب الفضل باختيارك اجابته كأفضل إجابة أو تمت الإجابة له

[Hesham.Abusna]

معلش آسف . قلي اعمل ايه . مش واخد بالي 

اكيد طبعا استاذنا العبقري . محمد هشام . صاحب الفضل الاول و العرفان في الاجابة . كل كلمات الثناء و عبارات الامتنان لا توفيه . حقه .. 

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

[Foksh]

10 دقائق مضت, Hesham.Abusna said:

معلش آسف . قلي اعمل ايه . مش واخد بالي 

 

قم بإلغاء إختيارك لإجابتي ، و اختر إجابته  ، بدلاً من إجابتي   

[Hesham.Abusna]

حقك عليا أنا آسف . مش عارف قلي ادوس على انه زرار . مش بشوف كويس السكر مبهدل نظري بشوف بالعدسة بعد النظارة 

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

[Foksh]

ولا يهمك ، وألف سلامة عليك .. ونسأل الله لكم الشفاء من كل بلاء ..

في إجابتي اللي حضرتك اخترتها ، حتلاقي زر الغاء اختيار تمت الإجابة ، دوس عليه ، وبعدين روح لإجابة الأستاذ محمد هشام واختارها بالضغط على زر تمت الإجابة .

 

وسلامتك 

[Hesham.Abusna]

في انه حته فيها الغاء الاجابة . انا بدوس على الي عليها لون اخضر مفيش حاجة بيحصل فيها . على فكرة الخط صغير جدا في المنتدى . 

 

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

[Foksh]

الان, Hesham.Abusna said:

في انه حته فيها الغاء الاجابة . انا بدوس على الي عليها لون اخضر مفيش حاجة بيحصل فيها 

 

يا صاحبي ، في المشاركة اللي انت اخترتها لي  . حتلاقيها أصبحت الغاء اختيار تمت الإجابة .

[Hesham.Abusna]

تمام .. على فكرة مكنتش باينة خالص . انا فضلت ادوس على اللون الاخضر .. ابقو كبرو الخط شوية .. حصل خير .. كل سنة و انتو طيبين .. شكرا لكل المنتدى . محترمين 

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

[Foksh]

الان, Hesham.Abusna said:

تمام .. على فكرة مكنتش باينة خالص . انا فضلت ادوس على اللون الاخضر .. حصل خير 

لا ولا يهمك ,, حصل خير

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

 

ونتمنى إنك تلاقي إجاباتك وحلول مشاكلك هنا مع نخبة من الأساتذة والمعلمين  .

 

دمتم خير سالمين 

[Hesham.Abusna]

اكيد طبعا محدش ينكر فضل اهل الفضل .. اي زميل يساعد له كل التحية و الثناء و الشكر .. تحياتي لكم جميعا ايها الرائعون . أتشرف بكم جميعا .

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

[elmansyeswa]

 

بارك الله فيك وجعله بميزان حسناتك