اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

طلب التعديل في الكود لترتيب من أعلى معدل عام إلى أصغر معدل عام في كل الملفات


إذهب إلى أفضل إجابة Solved by أ / محمد صالح,

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

السلام عليكم

من فضلكم

طلب التعديل على الكود التالي:

Sub insertformula()
Application.ScreenUpdating = 0
Dim strfile As String, objBook As Workbook, lr As Long, c As Integer
strfile = Dir(ThisWorkbook.Path & "\*.xlsx", vbNormal)
While strfile <> ""
Set objBook = Workbooks.Open(ThisWorkbook.Path & "\" & strfile)
c = objBook.Sheets("data").Range("b10").CurrentRegion.Columns.Count
lr = objBook.Sheets("data").Range(IIf(c = 10, "j", "l") & Rows.Count).End(xlUp).Row
objBook.Sheets("data").Range(IIf(c = 10, "k", "m") & "12").Formula = "=IF(Or(" & IIf(c = 10, "j", "l") & "12<5," & IIf(c = 10, "j", "l") & "12=""ن.م.ر""),""يكرر"",""ينتقل"")"
objBook.Sheets("data").Range(IIf(c = 10, "k", "m") & "12").AutoFill Destination:=objBook.Sheets("data").Range(IIf(c = 10, "k", "m") & "12:" & IIf(c = 10, "k", "m") & lr)
objBook.Sheets("data").Range("b12").Select
objBook.Close 1
strfile = Dir()
Wend
Application.ScreenUpdating = 1
MsgBox "Done"
End Sub

بحيث قبل Msgbox"Done

يقوم الكود بإعادة الترتيب على أساس المعدل العام من أكبر معدل عام إلى أصغر معدل عام

وجزاكم الله خيرا

3.rar

رابط هذا التعليق
شارك

السلام عليكم

هل من اقتراحات إخوتي الكرام؟

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

وحزاكم الله خيرا

رابط هذا التعليق
شارك

السلام عليكم

عيدكم مبارك سعيد 

تقبل الله منا ومنكم

Sub formulettrier()
Application.ScreenUpdating = 0
Dim strfile As String, objBook As Workbook, lr As Long, c As Integer, rg As Range
strfile = Dir(ThisWorkbook.Path & "\*.xlsx", vbNormal)
While strfile <> ""
Set objBook = Workbooks.Open(ThisWorkbook.Path & "\" & strfile)
c = objBook.Sheets("data").Range("b10").CurrentRegion.Columns.Count
lr = objBook.Sheets("data").Range(IIf(c = 10, "j", "l") & Rows.Count).End(xlUp).Row
objBook.Sheets("data").Range(IIf(c = 10, "k", "m") & "12").Formula = "=IF(Or(" & IIf(c = 10, "j", "l") & "12<5," & IIf(c = 10, "j", "l") & "12=""ن.م.ر""),""يكرر"",""ينتقل"")"
objBook.Sheets("data").Range(IIf(c = 10, "k", "m") & "12").AutoFill Destination:=objBook.Sheets("data").Range(IIf(c = 10, "k", "m") & "12:" & IIf(c = 10, "k", "m") & lr)

    'البحث عن عمود المعدل العام للفلترة
    Set rg = Rows("10:10").Find(What:="المعدل العام", LookAt:=xlWhole)
 
    AutoFilter.Sort.SortFields.Clear
    AutoFilter.Sort.SortFields.Add
        Key:=rg, _
        SortOn:=xlSortOnValues, _
        Order:=xlDescending, _
        DataOption:=xlSortNormal
    With .AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End With

objBook.Sheets("data").Range("b12").Select
objBook.Close 1
strfile = Dir()
Wend
Application.ScreenUpdating = 1
MsgBox "هشام:تمت عملية إضافة القرار والترتيب من أعلى معدل إلى أقل معدل "
End Sub

من فضلكم أساتذة

ما العيب في هذا الكود لإنجاز ترتيب من أعلى معدل عام إلى أقل معدل عام في كل الملفات 

خاصة ابتداء من :

'البحث عن عمود المعدل العام للفلترة

في الكود السابق

وجزاكم الله خيرا

رابط هذا التعليق
شارك

جميل جدا 

إن تقوم بتسجيل ماكرو لما تريده 

وتحاول دمجه في الكود الاصلي

واقترح عليك حتى يتم التنفيذ على الملف المفتوح 

إن تضيف

objBook.Sheets("data")

قبل كلمة range او كلمة autofilter او كلمة rows 

عيدكم مبارك 

رابط هذا التعليق
شارك

شكرا جزيلا لردك الطيب

أصبحت تخرج لي نافذة الخطإ في:

        Key:=rg, _SortOn:=xlSortOnValues, _Order:=xlDescending, _DataOption:=xlSortNormal

ما حل هذه المشكلة جزاكم الله خيرا

رابط هذا التعليق
شارك

جرب الصف 11 في تعريف rg لأن المعدل العام خلية مدمجة وتأكد من كتابتها في الخلية بهذه الصورة فربما يكون بعدها مسافة زائدة 

رابط هذا التعليق
شارك

  • أفضل إجابة

الصواب في الفرز على الصف 11 ولكن

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

فأصبحت الخلايا b11 , c11, d11, j11, k11 فارغة مما يجعل عملية الفرز غير دقيقة

ولذا أضفت كود فك الدمج لهذه الخلايا قبل كود الفرز

Sub insertformula3()
Application.ScreenUpdating = 0
Dim strfile As String, col As String, col1 As String, objBook As Workbook, lr As Long, c As Integer
strfile = Dir(ThisWorkbook.Path & "\*.xlsx", vbNormal)
While strfile <> ""
Set objBook = Workbooks.Open(ThisWorkbook.Path & "\" & strfile)
c = objBook.Sheets("data").Range("b10").CurrentRegion.Columns.Count
col = IIf(c = 10, "j", "l")
col1 = IIf(c = 10, "k", "m")
lr = objBook.Sheets("data").Range(col & Rows.Count).End(xlUp).Row
objBook.Sheets("data").Range(col1 & "12").Formula = "=IF(Or(" & col & "12<5," & col & "12=""ن.م.ر""),""يكرر"",""ينتقل"")"
objBook.Sheets("data").Range(col1 & "12").AutoFill Destination:=objBook.Sheets("data").Range(col1 & "12:" & col1 & lr)

If objBook.Sheets("data").AutoFilterMode Then Selection.AutoFilter
objBook.Sheets("data").Range("b10:b11").UnMerge
objBook.Sheets("data").Range("b11").Value = "رقم التلميذ"
objBook.Sheets("data").Range("b10").ClearContents
objBook.Sheets("data").Range("c10:c11").UnMerge
objBook.Sheets("data").Range("c11").Value = "الاسم والنسب"
objBook.Sheets("data").Range("c10").ClearContents
objBook.Sheets("data").Range("d10:d11").UnMerge
objBook.Sheets("data").Range("d11").Value = "النوع"
objBook.Sheets("data").Range("d10").ClearContents
objBook.Sheets("data").Range(col & "10:" & col & "11").UnMerge
objBook.Sheets("data").Range(col & "11").Value = "المعدل العام"
objBook.Sheets("data").Range(col & "10").ClearContents
objBook.Sheets("data").Range(col1 & "10:" & col1 & "11").UnMerge
objBook.Sheets("data").Range(col1 & "11").Value = "قرار المجلس"
objBook.Sheets("data").Range(col1 & "10").ClearContents

objBook.Sheets("data").Rows("11:11").AutoFilter
objBook.Sheets("Data").AutoFilter.Sort.SortFields.Clear
objBook.Sheets("Data").AutoFilter.Sort.SortFields.Add2 Key:=Range(IIf(c = 10, "j11", "l11")), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With objBook.Sheets("Data").AutoFilter.Sort
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

objBook.Sheets("data").Range("b12").Select
objBook.Close 1
strfile = Dir()
Wend
Application.ScreenUpdating = 1
MsgBox "هشام:تمت عملية إضافة القرار"
End Sub

عيدكم مبارك

  • Thanks 1
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

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

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information