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

Hesham.Abusna · يونيو 13

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

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

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

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

مشكور جدا .

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

**محمد هشام.** · يونيو 13

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

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

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 · يونيو 14

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** · يونيو 14

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

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

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

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

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

xlOpenXMLWorkbook  ' أي .xlsx

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

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

Hesham.Abusna · يونيو 14

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

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

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

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

**Foksh** · يونيو 14

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

Hesham.Abusna · يونيو 14

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

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

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

**Foksh** · يونيو 14

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

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

قم بإلغاء إختيارك لإجابتي ، و اختر إجابته image.png.4d5beb39f7e4a169769e30614348084e.png ، بدلاً من إجابتي :wub:

Hesham.Abusna · يونيو 14

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

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

**Foksh** · يونيو 14

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

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

وسلامتك :wub:

Hesham.Abusna · يونيو 14

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

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

**Foksh** · يونيو 14

الان, Hesham.Abusna said:

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

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

Hesham.Abusna · يونيو 14

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

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

**Foksh** · يونيو 14

في 14‏/6‏/2025 at 17:18, Hesham.Abusna said:

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

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

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

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

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

Hesham.Abusna · يونيو 14

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

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

elmansyeswa · يونيو 14

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

Hesham.Abusna · منذ 10 ساعات

في 14‏/6‏/2025 at 02:26, محمد هشام. 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 · 20 downloads

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

تحية طيبة . محبة و احترام لشخصكم العزيز

في اطار تجربة هذا الكود المتميز . لاحظت ان الكود لايعمل جيدا على الملفات بصيغة الماكرو او الملفات التي بعا معادلات كثيرة و اكواد

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

آسف على تعبك .

هل هناك حل لهذا

**محمد هشام.** · منذ 3 ساعات

7 ساعات مضت, Hesham.Abusna said:

لاحظت ان الكود لايعمل جيدا على الملفات بصيغة الماكرو او الملفات التي بعا معادلات كثيرة و اكواد

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

أخي @Hesham.Abusna

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

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

على العموم جرب الكود التالي على ملفك الأصلي ووافينا بالنتيجة

Option Explicit
Sub Sauvegarde_WB()
    Dim dossier$, chemin$, sFichier$, sPath$, sNom$
    Dim WS As Worksheet, newWB As Workbook, newWs As Worksheet
    Dim n As Integer, data As Variant, OnRng As Range, _
                   shp As Shape, col As Long, rw As Long

    On Error GoTo EndClear
    SetApp False

    Set newWB = Workbooks.Add(xlWBATWorksheet)
    newWB.Sheets(1).Name = "Temp"
    n = 1

    For Each WS In ThisWorkbook.Worksheets
        Set newWs = newWB.Sheets.Add(After:=newWB.Sheets(newWB.Sheets.Count))
        sNom = Left(WS.Name, 31)
        Do While f(sNom, newWB)
            sNom = Left(WS.Name, 28) & "_" & n: n = n + 1
        Loop
        newWs.Name = sNom

        Set OnRng = WS.UsedRange
        If OnRng.Cells.Count > 1 Then
            data = OnRng.Value
            newWs.Range("A1").Resize(UBound(data, 1), UBound(data, 2)).Value = data
            
            OnRng.Copy
            newWs.Range("A1").PasteSpecial xlPasteFormats
            Application.CutCopyMode = False
            For col = 1 To OnRng.Columns.Count
                newWs.Columns(col).ColumnWidth = WS.Columns(col).ColumnWidth
            Next col
            For rw = 1 To OnRng.Rows.Count
                newWs.Rows(rw).RowHeight = WS.Rows(rw).RowHeight
            Next rw

            Application.Goto newWs.Range("A1"), True
        End If

        On Error Resume Next
        For Each shp In newWs.Shapes
            If shp.Type = msoFormControl Or shp.Type = msoOLEControlObject Then shp.Delete
        Next shp
        On Error GoTo EndClear
    Next WS

    newWB.Sheets("Temp").Delete
    dossier = ThisWorkbook.Path & "\Workbook_Copy"
    If Dir(dossier, vbDirectory) = "" Then MkDir dossier
    sPath = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1)
    sFichier = sPath & "_" & Format(Now, "dd-mm-yyyy_hh-nn-ss") & ".xlsx"
    chemin = dossier & "\" & sFichier
    newWB.Sheets(1).Activate
    newWB.SaveAs Filename:=chemin, FileFormat:=xlOpenXMLWorkbook
    newWB.Close False

    MsgBox "تم نسخ الملفات بنجاح", vbInformation
    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

Private Function f(sheetName As String, wb As Workbook) As Boolean
    Dim sht As Worksheet
    For Each sht In wb.Sheets
        If sht.Name = sheetName Then f = True: Exit Function
    Next sht
    f = False
End Function

إليك المرفق مرة أخرى بعد إظافة بعض المعادلات الجديدة للتجربة

TEST v2.rar

تم تعديل منذ 3 ساعات بواسطه محمد هشام.

تسجيل الدخول

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

الردود الموصى بها

Hesham.Abusna

محمد هشام.

Hesham.Abusna

Foksh

Hesham.Abusna

Foksh

Hesham.Abusna

Foksh

Hesham.Abusna

Foksh

Hesham.Abusna

Foksh

Hesham.Abusna

Foksh

Hesham.Abusna

elmansyeswa

Hesham.Abusna

محمد هشام.

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information