طريقة سهلة جدا تقليل حجم ملفات اكسل 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 كيلو بايت
يتحول الملف الى حجم لايذكر
وهذة هى الطريقة السحرية المجربة فعليا
استاذ غازي الله يبارك في حسناتك واهلك على هذه الشروحات انا نريد عمل شهادة نجاح اي وثيقة ونريد عمل لهل رقم اشاري يكون الرقم الاول علي اليسار متسلسل والارقام على اليمين تدل على السنة والشهر وتتغير لوحدها فمثلا 19512______19 هى السنة ---5 الشهر ____12 رقم متسلسلومثلا اخر 207123____20 السنة الفان _____7 الشهر السابع _____123 رقم الوثيقة المتسلسل
ردحذفتكملة نريد كذلك نقل اسم الطالب ورقمه الاشاري الى ورقة اخرى ولكم منا جزيل الشكر والعرفان
ردحذفعند تطبيق الكود باستخدام نفس الخطوات تظهر الرسالة التالية
ردحذفRun-time error'1004':
Delete method of range class failed
هذه المشكلة تظهر في تعدد الصفحات أخي الكريم أو ربما عند تسمية صفحة باللغة العربية
حذفحاول تغير اسم الشيت الى اللغة الانكليزية
الحل الأخر
انك تعدل الكود
تحذف خيار for في اول الكود
ثم تقوم بتثبيت اسم الشيت بشكل يدوي قبل with ws
Set ws=worksheets("ooo") 'ooo is name your sheet
قم بتبديل ooo الى اسم الشيت
كما نحذف end for في نهاية الكود
وتعمل ان شاء الله
استاذ عماد الكود بيعمل مع بعض من المصنفات وبعد ازالة الحاية كمان لكن بيدى خطأ فى السطر ده Do Until .Cells(j, k).Left > Shp.Left + Shp.Width
ردحذفاستاذ عماد كيف ارتب أسماء الشيتات ترتيبا ابجديا
ردحذفالسلام عليكم استاذ عماد جزاك الله خير علي ما تقدمة من علم واريد برنامج حضور وانصراف ببرنامج الاكسل مع ترحيل ايام الافراد في ورقة واحدة خلال الشهر
ردحذفالسلام عليكم ممكن تبعتلي الكود على الاميل وشكرا
ردحذفشكرا على هذا العمل الجبار
ردحذفهل ممكن تبعث لي الكود عبر اإيمي بعد
ردحذفجزاكم الله خيراً
ردحذفممكن ترسل لي الكود لو سمحت بليز
ردحذفمشكورا لو بالامكان السؤال بخصوص اكسل vba فى userform "عايز اضيف سطر جديد بين سطرين موجودين بمعنى لو السطر رقم 5 مكتوب فيه بيانات وكذلك السطر رقم 6 اريد اضافة سطر بينهم بحيث ان الصف الجديد ياخذ الترتيب 6 والسطر رقم 6 ياخذ الترتيب رقم7 وهكذا يتم ترحيل باقى الاسطر بناء على عملية الاضافة الجديدة"
ردحذفممكن إرسال الكود على الأيميل hmh-04@hotmail.com
ردحذفممكن ارسال الكود بعد اذنك khaled_elnade@hotmail.com وجزاكم الله خيرا
ردحذف