سؤال بخصوص حجم ملف وصعوبة في فتحة ؟

[ريان أحمد]

السلام عليكم

 

ممكن تزويدنا بالكودال لوحده

 

وجزاكم الله كل خير وهل ينج في أفيس 2003

[وليد فتحي]

الأستاذ/ وليد

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

لا لم تطول علي بعد - سأخبرك بذلك حينها

هذا الكود تشغله فقط عند الحاجة إذا أستشعرت ثقل الملف وتأخر فتحه

تقبل تحياتي

 

استاذ حماده

عندما شغلت الكود ظهرت لي رسالة خطأ بالكود

[حمادة باشا]

السلام عليكم

 

ممكن تزويدنا بالكودال لوحده

 

وجزاكم الله كل خير وهل ينج في أفيس 2003

 

الأستاذ/ ريان

الكود مرفق في الأسفل

نعم هو بالأساس مصمم لإصدار 2003

 

 

الأستاذ/ وليد

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

لا لم تطول علي بعد - سأخبرك بذلك حينها

هذا الكود تشغله فقط عند الحاجة إذا أستشعرت ثقل الملف وتأخر فتحه

تقبل تحياتي

 

استاذ حماده

عندما شغلت الكود ظهرت لي رسالة خطأ بالكود

 

 

الأستاذ/ وليد

نعم الرسالة تظهر ولكن بعد أداء الكود مهمته في حذف عناوين النطاقات الفارغة - يمكنك التغاضي عنها فليس لها تأثير

عموما قمت بالتعديل حتي لاتظهر الرسالة - تفضل الكود الجديد :

 

'========== Reduce File Size & Fix Blank UsedRange By Excel ==============
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)
             '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
                j = Shp.TopLeftCell.Row
                k = Shp.TopLeftCell.Column
                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 Shp
            .Range(Cells(1, LastCol + 1).Address & ":IV65536").Delete
            .Range(Cells(LastRow + 1, 1).Address & ":IV65536").Delete
        End With
    Next ws
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

تقبل تحياتي

 

[وليد فتحي]

جزاك الله كل خير استاذ حماده وجاري التجربة

[ريان أحمد]

شكرا لك أستاذي  وجزاك الله كل خير  على الإستجابة 

 

ودمت ذخرا للمنتدى