بعض التعديلات على ملف التوجيهات للاخ ياسر

[اشرف النعاس]

اريد عند الضغط على زر التوجيه يقوم بحساب اولا عمود عدد النقاط لكل طالب و التي تساوي (R *X)/y  و من تم يقوم بتوجيه بحيت يكون هذا الكود =Wish(D8:R27,X12:Y23,3,14,15,10) بداخل الزر بدلا من بداخل الخلية و ايضا ان لا يكون توجيه لعدد معين من الطلبة حيت كلما اضافت طلبه يقوم بالقيام  بالتوجيه  
اكتر توضيح في الملف المرفق 

Export Workbooks Using Filter Method.rar

[عبد العزيز البسكري]

و أنا بدوري أريد أن يجيبك أحدهم بسرعة

[اشرف النعاس]

هل من رد

[اشرف النعاس]

هل من رد

[ياسر خليل أبو البراء]

أخي الكريم لم أفهم الكثير ..

يرجى تحديد طلب بعينه مع شرحه بالتفصيل لتجد المساعدة مني أو من غيري

وطالما أنه لا توجد استجابة لموضوع فمعنى ذلك أن الأمر مبهم لدى الجميع

قم بإرفاق النتائج المتوقعة .. ولا تفترض أن الجميع يفهم ما تطلب بدون شرح للمطلوب

[اشرف النعاس]

قمت باكتر ايضاح اخي ياسر في الملف المرفق في الاسفل 

Export Workbooks Using Filter Method.rar

[ياسر خليل أبو البراء]

أخي الكريم أشرف

 إليك الكود التالي عله يفي بالغرض

Sub ConvertFormulaVBA()
    Dim LR As Long
    LR = Cells(Rows.Count, "D").End(xlUp).Row
    
    With Range("R8:R" & LR)
        .Formula = "=(T8*V8)/U8"
        .Value = .Value
    End With
    
    With Range("S8:S" & LR)
        .FormulaArray = "=Wish(D8:R27,X12:Y23,3,14,15,10)"
        .Value = .Value
    End With
End Sub

 

تم تعديل أغسطس 15, 2015 بواسطه ياسر خليل أبو البراء

[اشرف النعاس]

تمام اخي ياسر و لكن اريد منك اخر تعديل للكود هو 

=Wish(D8:R27,X12:Y23,3,14,15,10)

و هو ان يكون الكود من D8 الى R ما لا نهاية بدلا من D8 : R27

و ايضا قمت باضافة الكود للزرالتوجيه و لكن بعد الاضافة اتر ايضا على زر مستخرجات الملفات حيت اصبح يستخرج قوائم التوجهات الكلية فقط و ليس كما كان سابقا يستخرج ملف اكسل لكل توجيه اكتر توضيح موجود في الملف المرفق 

Export Workbooks Using Filter Method.rar

تم تعديل أغسطس 16, 2015 بواسطه اشرف النعاس

[ياسر خليل أبو البراء]

إليك الطلب الأول

Sub ConvertFormulaVBA()
    Dim LR As Long
    LR = Cells(Rows.Count, "D").End(xlUp).Row
    
    With Range("R8:R" & LR)
        .Formula = "=(T8*V8)/U8"
        .Value = .Value
    End With
    
    With Range("S8:S" & LR)
        .FormulaArray = "=Wish(D8:R" & LR & ",X12:Y23,3,14,15,10)"
        .Value = .Value
    End With
End Sub

بحيث لا تحدد آخر صف بنفسك

بالنسبة للطلب الثاني إليك الكود

Sub YasserKhalil()
    Dim rngData As Range, rngToCopy As Range, arrFilter, I As Long, J As Long

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    If Len(Dir(ThisWorkbook.Path & "\Results", vbDirectory)) = 0 Then
        MkDir ThisWorkbook.Path & "\Results"
    End If

    Set rngData = Range("D7:S" & Cells(Rows.Count, "D").End(xlUp).Row)

    arrFilter = Application.Transpose(Range("X12:X" & Cells(Rows.Count, "X").End(xlUp).Row))
    ReDim Preserve arrFilter(1 To UBound(arrFilter) + 1)
    arrFilter(UBound(arrFilter)) = "<>بدون توجيه"

    For I = 1 To UBound(arrFilter)
        ActiveSheet.AutoFilterMode = False
        rngData.AutoFilter Field:=16, Criteria1:=arrFilter(I)
        J = rngData.Columns(1).SpecialCells(xlCellTypeVisible).Count
        If J = 1 Then GoTo skipper
        Set rngToCopy = Intersect(Union(Columns("D:E"), Columns("R:S")), rngData.SpecialCells(xlCellTypeVisible))

        Workbooks.Add
        With ActiveSheet.Cells
            .Clear
            .FormatConditions.Delete
        End With
        
        rngToCopy.Copy
        Range("B5").PasteSpecial xlPasteValues
        Columns(2).ColumnWidth = 11: Columns(3).ColumnWidth = 28: Columns(4).ColumnWidth = 10.5: Columns(5).ColumnWidth = 15

        With Range("B2:E3")
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .MergeCells = True
            .Font.Size = 20
            .Value = IIf(I < UBound(arrFilter), arrFilter(I), "قوائم التوجهات الكلية")
        End With

        If I < UBound(arrFilter) Then
            Columns("E").Delete
            FormatRange
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\Results\" & arrFilter(I) & ".xlsx"
        Else
            FormatRange
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\Results\" & "قوائم التوجهات الكلية" & ".xlsx"
        End If

        ActiveWorkbook.Close
skipper:
    Next I

    ActiveSheet.AutoFilterMode = False
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Sub FormatRange()
    With Range("B5").CurrentRegion
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Font.Size = 13
        .Borders.Weight = xlThin
        .BorderAround Weight:=xlThick
    End With
    Range("B2").Select
End Sub

إذا كان فيه أي طلبات أخرى يرجى طرح موضوع جديد حيث أنه يفضل أن يكون كل موضوع لطلب واحد فقط ...

وصل الموضوع هنا إلى 4 طلبات ( ......................)

تم تعديل أغسطس 16, 2015 بواسطه ياسر خليل أبو البراء

[اشرف النعاس]

بارك الله فيك اخي ياسر الحمد لله وصلت للمطلوب و لدي بعض المطالب الاخرى لاحقا سوف افتح موضوع جديد لها 

 

[ياسر خليل أبو البراء]

الحمد لله الذي بنعمته تتم الصالحات

ومشكور على الاستجابة لمطلبي بفتح موضوع جديد بالطلبات الجديدة ليشارك الجميع ...