السبت، 22 يونيو 2019

الطريقة السحرية تقليل حجم ملفات اكسل 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 كيلو بايت 
يتحول الملف الى حجم لايذكر 
وهذة هى الطريقة السحرية المجربة فعليا 

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


هناك 6 تعليقات:

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

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

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

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

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

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

    ردحذف

من نحن

authorمرحبا، أسمي عماد غازى وهذه مدونتي أسعى دائما لأقدم لكم أفضل المواضيع الخاصة بالاوفيس
المزيد عني →

التصنيفات

نموذج الاتصال

الاسم

بريد إلكتروني *

رسالة *

إجمالي مرات مشاهدة الصفحة