-->

الطريقة السحرية تقليل حجم ملفات اكسل Excel macro

طريقة سهلة جدا تقليل حجم ملفات اكسل Excel macro
اهلا بكم متابعى موقع ومدونة عالم الاوفيس
فى احيان كثيرة جدا تميل احجام ملفات اكسل الى الزيادة فى الحجم بشكل مبالغ فية دون معرفة سبب هذة الزيادة فى الحجم 
مما يؤدى الى بطئ شديد فى فتح ملفات اكسل والعمل عليها .



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

وجدنا الطريقة السحرية والكود السحرى للمبدع والرائع استاذ / ياسر خليل (ابو البراء ) فى مشاركة لة فى نفس الموضوع
حبيت اشارك معكم الكود حتى تستفيدوا منه جميعا فى عملكم
اليكم الكود
Option Explicit

Sub ExcelDiet()
    Dim j               As Long
    Dim k               As Long
    Dim LastRow         As Long
    Dim LastCol         As Long
    Dim ColFormula      As Range
    Dim RowFormula      As Range
    Dim ColValue        As Range
    Dim RowValue        As Range
    Dim Shp             As Shape
    Dim ws              As Worksheet
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    On Error Resume Next
    
    For Each ws In Worksheets
        With ws
            'Find the last used cell with a formula and value
            'Search by Columns and Rows
            On Error Resume Next
            Set ColFormula = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
            Set ColValue = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, _
            LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
            Set RowFormula = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
            Set RowValue = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
            On Error GoTo 0
            
            'Determine the last column
            If ColFormula Is Nothing Then
                LastCol = 0
            Else
                LastCol = ColFormula.Column
            End If
            If Not ColValue Is Nothing Then
                LastCol = Application.WorksheetFunction.Max(LastCol, ColValue.Column)
            End If
            
            'Determine the last row
            If RowFormula Is Nothing Then
                LastRow = 0
            Else
                LastRow = RowFormula.Row
            End If
            If Not RowValue Is Nothing Then
                LastRow = Application.WorksheetFunction.Max(LastRow, RowValue.Row)
            End If
            
            'Determine if any shapes are beyond the last row and last column
            For Each Shp In .Shapes
                j = 0
                k = 0
                On Error Resume Next
                j = Shp.TopLeftCell.Row
                k = Shp.TopLeftCell.Column
                On Error GoTo 0
                If j > 0 And k > 0 Then
                    Do Until .Cells(j, k).Top > Shp.Top + Shp.Height
                        j = j + 1
                    Loop
                    If j > LastRow Then
                        LastRow = j
                    End If
                    Do Until .Cells(j, k).Left > Shp.Left + Shp.Width
                        k = k + 1
                    Loop
                    If k > LastCol Then
                        LastCol = k
                    End If
                End If
            Next
            
            .Range(.Cells(1, LastCol + 1), .Cells(.Rows.Count, .Columns.Count)).EntireColumn.Delete
            .Range("A" & LastRow + 1 & ":A" & .Rows.Count).EntireRow.Delete
        End With
    Next
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

الكود ياخذ فى حدود من دقيقة الى دقيقة ونصف عمل وبعد ذلك ستجد ان ملفك اصبح حجمة بدلا 6 ميجا بيت اصبح 38 كيلو بايت 
يتحول الملف الى حجم لايذكر 
وهذة هى الطريقة السحرية المجربة فعليا 

 لتحميل ملف العمل
لمشاهدة شرح الفيديو 


Emad ghazi
كاتب المقالة
كاتب ومحرر اخبار اعمل في موقع عالم الاوفيس .

جديد قسم : اكسل متقدم

  1. استاذ غازي الله يبارك في حسناتك واهلك على هذه الشروحات انا نريد عمل شهادة نجاح اي وثيقة ونريد عمل لهل رقم اشاري يكون الرقم الاول علي اليسار متسلسل والارقام على اليمين تدل على السنة والشهر وتتغير لوحدها فمثلا 19512______19 هى السنة ---5 الشهر ____12 رقم متسلسلومثلا اخر 207123____20 السنة الفان _____7 الشهر السابع _____123 رقم الوثيقة المتسلسل

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

    ردحذف
  3. عند تطبيق الكود باستخدام نفس الخطوات تظهر الرسالة التالية
    Run-time error'1004':
    Delete method of range class failed

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

      حاول تغير اسم الشيت الى اللغة الانكليزية

      الحل الأخر
      انك تعدل الكود
      تحذف خيار for في اول الكود
      ثم تقوم بتثبيت اسم الشيت بشكل يدوي قبل with ws

      Set ws=worksheets("ooo") 'ooo is name your sheet

      قم بتبديل ooo الى اسم الشيت

      كما نحذف end for في نهاية الكود

      وتعمل ان شاء الله

      حذف
  4. استاذ عماد الكود بيعمل مع بعض من المصنفات وبعد ازالة الحاية كمان لكن بيدى خطأ فى السطر ده Do Until .Cells(j, k).Left > Shp.Left + Shp.Width

    ردحذف
  5. استاذ عماد كيف ارتب أسماء الشيتات ترتيبا ابجديا

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

    ردحذف
  7. السلام عليكم ممكن تبعتلي الكود على الاميل وشكرا

    ردحذف
  8. شكرا على هذا العمل الجبار

    ردحذف
  9. هل ممكن تبعث لي الكود عبر اإيمي بعد

    ردحذف
  10. ممكن ترسل لي الكود لو سمحت بليز

    ردحذف
  11. مشكورا لو بالامكان السؤال بخصوص اكسل vba فى userform "عايز اضيف سطر جديد بين سطرين موجودين بمعنى لو السطر رقم 5 مكتوب فيه بيانات وكذلك السطر رقم 6 اريد اضافة سطر بينهم بحيث ان الصف الجديد ياخذ الترتيب 6 والسطر رقم 6 ياخذ الترتيب رقم7 وهكذا يتم ترحيل باقى الاسطر بناء على عملية الاضافة الجديدة"

    ردحذف
  12. ممكن إرسال الكود على الأيميل hmh-04@hotmail.com

    ردحذف
  13. ممكن ارسال الكود بعد اذنك khaled_elnade@hotmail.com وجزاكم الله خيرا

    ردحذف