انشاء ملف اكسل وفقا لشروط محدد

اشرف النعاس · يوليو 21, 2015

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

اريد انشاء ملفات اكسل يحتوي على قوائم وفقا لشروط محدده اكتر توضيح موجود في الملف المدرج في الاسفل

اريد ان اشكرا الاخ ياسر و كذلك باقي اعضاء المنتدى على الاداء و المجهود الاكتر من رائع

Pupils Distribution According To Marks & Wishees V2.rar

أحمد مرجان · يوليو 21, 2015

برجاء التوضيح ما هي الشروط التى تقصدها، وعلى أى أساس يتم تحديد الرغبات للاسم؟؟

اشرف النعاس · يوليو 21, 2015

اخي احمد بخصوص تحديد الرغبات تتم من قبل الطالب .... هو نفس ملف الأخ الفاضل هشام كمال احمد السريف .

ام بخصوص الشروط فالشرح موجود بداخل الملف " المطلوب استخراج ملف لكل توجيه نهائي على حد و كذالك ملف لتوجيهات النهائية كامل مرتب كل الشرح موجود في الملف

ياسر خليل أبو البراء · يوليو 21, 2015

أخي أشرف لابد من مزيد من التوضيح

تقصد استخراج كل مجموعة بيانات لكل توجيه في مصنف (ملف) .. ما هو الامتداد المرغوب ؟ ما هو المسار المراد تصدير البيانات إليه ؟ ما هي آلية العمل ؟

أقصد هل كل توجيه له زر أمر منفصل أم تريد عمل زري أمر أحدهما يتسخرج كل توجيه على حدا والآخر يستخرج جميع التوجيهات ؟

ما هي شكل النتائج المتوقعة في النهاية ؟ أقصد هل هناك أعمدة سيتم حذفها أم أنه لا يتم الإبقاء إلا على عمودين فقط عمود الاسم وعمود م. الترتيب؟

لا يفترض ان أسأل .. بل يفترض أن توضح كل ما سبق دون سؤال حتى لا يتشعب الموضوع بدون داعي

لابد أن تعلم أن توضيح المسألة يمثل 90% من الحل

اشرف النعاس · يوليو 21, 2015

اولا بارك الله فيك اخي ياسر
تانيا بخصوص الاسئلة

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

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

شكل النتائج المستخرجة سوف تكون متل الملفات المدرج في الاسفل و شكرااا

محاسبة وجباية.rar

موارد بشرية .rar

قـــــوائم التوجهـــــــات الكلـــــية .rar

اشرف النعاس · يوليو 22, 2015

هل من رد

ياسر خليل أبو البراء · يوليو 22, 2015

الأخ الكريم اشرف النعاس ...

أقترح عليك اقتراح أفضل .. لربما يكون أفضل في وجهة نظري

ما رأيك بعمل كود يقوم بكل ما ذكرت ؟؟ أعني أن يتم تصدير مصنفات بكل توجيه على حدا وكل التوجيهات مرة واحدة بضغطة زر واحدة .. أي يتم تجميع كل الطلبات في الموضوع في طلب واحد ومختصر

اشرف النعاس · يوليو 23, 2015

اخي ياسر هل تقصد عند الضغط على زر مرة واحدة يقوم بإنشاء عدة ملفات يحتوي على الطلبات او ملف واحد فقط يحتوي على الطلبات ؟

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

ياسر خليل أبو البراء · يوليو 23, 2015

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

أنت طلبت أن يكون هناك زر أمر لكل توجيه على حدا

لما لا يتم تصدير جميع التوجيهات (كل توجيه على حدا) إلى ملف أو مصنف مستقل مرة واحدة ...ويتم تصدير مصنف آخر به كل التوجيهات

هذا ما قصدته

**مختار حسين محمود** · يوليو 23, 2015

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

أستأذن أخى وأستاذى العزيز ياسر خليل وأشارككم بهذه المحاولة التى أعتبرها بداية جيدة

أتفق مع رأى أستاذى العزيز ياسر الأخير بالمشاركة 9 حيث يتم تصدير كل توجيه الى مصنف مستقل

ويتم تصدير كل التوجيهات الى مصنف عام يجمع الكل فهو الأيسر والأسهل والأقرب الى الصواب

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

الكود :


Sub MOKHTARTSET()

    Dim myDir As String, C As Range, WB As Workbook, NWB As Workbook, Rng1 As Range, Rng2 As Range
    
    Set WB = ThisWorkbook
    myDir = ActiveWorkbook.Path & "\" & "My Workbook"
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    On Error Resume Next
    MkDir myDir
    On Error GoTo 0
    
    '---------------------------------------------------------------------------------
    
        WB.Sheets("Final").Select
        Columns("F:Q").Select
        Selection.EntireColumn.Hidden = True
        
        Set Rng1 = WB.Sheets("Final").Range("d7:s27").SpecialCells(xlCellTypeVisible)
        Rng1.Select
        Selection.Copy
        
        Set NWB = Workbooks.Add
        ActiveSheet.Range("A4").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
        
        Range("A4:D24").Select
        With Selection
        .HorizontalAlignment = xlCenter
        .Font.Size = 10
        .Borders.LineStyle = xlContinuous
        End With
                
        ActiveSheet.Range("B2") = "قـــــوائم التوجهـــــــات الكلـــــية "
         
         NWB.SaveAs Filename:=myDir & "\" & "قـــــوائم التوجهـــــــات الكلـــــية " & ".xlsx", CreateBackup:=False
         NWB.Close
         
         WB.Activate
         WB.Sheets("Final").Cells.Select
           
        Selection.EntireColumn.Hidden = False
        Range("X11").Select
        
       '--------------------------------------------------------------------------------------
        For Each C In Sheets("Final").Range("U12:U23")
    
        WB.Sheets("Final").Range("AA1").Value = C.Value
        
        ' -------------------------------------------------------------------------------
               
         WB.Sheets("Final").Activate
         Range("D7:S7").Select
         Selection.AutoFilter
         ActiveSheet.Range("$D$7:$S$27").AutoFilter Field:=16, Criteria1:="=" & C.Value, Operator:=xlAnd
         
         
         Range("F:Q,S:S").Select
         Selection.EntireColumn.Hidden = True
         
         Set Rng2 = WB.Sheets("Final").Range("D7:R27").SpecialCells(xlCellTypeVisible)
         Rng2.Select
         Selection.Copy
                 
         
         Set NWB = Workbooks.Add
         
         ActiveSheet.Range("A4").Select
         Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
         Application.CutCopyMode = False
        
         Range("A4:D10").Select
        
         With Selection
          .HorizontalAlignment = xlCenter
          .Font.Size = 10
          .Borders.LineStyle = xlContinuous
         End With
                
         ActiveSheet.Range("B2") = "الموجهون الى"
         ActiveSheet.Range("C2") = C.Value
                  
         NWB.SaveAs Filename:=myDir & "\" & C.Value & ".xlsx", CreateBackup:=False
         NWB.Close
                  
         WB.Activate
         WB.Sheets("Final").Cells.Select
         Selection.EntireColumn.Hidden = False
         Selection.AutoFilter
         Range("A1").Select
        
        '-----------------------------------------------------------------------------------
        
   Next C
    
   
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub

الكود ينتج عنه الملفات المطلوبة داخل مجلد باسم My Workbook فى مسار الملف أرجو أن يكون هو المطلوب.

Pupils Distribution According To Marks & Wishees by mokhtar .rar

ياسر خليل أبو البراء · يوليو 23, 2015

بارك الله فيك أخي الحبيب الغالي مختار

زيادة في الخير وإثراءً للموضوع

إليك الحل التالي ..حيث يتم إنشاء مصنف لكل توجيه ويستثنى "بدون توجيه" ، كما يستثنى "بدون توجيه" في مصنف "قوائم التوجهات الكلية"

يتم إنشاء مجلد في نفس مسار المصنف الحالي باسم Results يتم تصدير المصنفات به

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("U12:U" & Cells(Rows.Count, "U").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
        ActiveSheet.Cells.Clear
        rngToCopy.Copy Range("B5")
        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
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\Results\" & arrFilter(I) & ".xlsx"
        Else
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\Results\" & "قوائم التوجهات الكلية" & ".xlsx"
        End If
        ActiveWorkbook.Close
skipper:
    Next I

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

تقبل تحياتي

Export Workbooks Using Filter Method.rar

**مختار حسين محمود** · يوليو 24, 2015

الله الله عليك يا أبا البراء رائع هذا الكود رغم أن فيه شوية كلاكيع

استفسار : ليه تم استثناء مصنف لــ "بدون توجيه" ، كما تم استثناء "بدون توجيه" في مصنف "قوائم التوجهات الكلية"

مع أن من المفروض أن يعامل غير الموجهين كغيرهم فهم جزء من الكل ولا ده طلب لأخونا أشرف .دى نقطة

النقطة الثانية فى ملف أخونا أشرف وضع أسماء التوجهات النهائية فى النطاق "U12:U23" وفيهم التوجه التسويق 3 مع أنه مش موجود فى العمود S

وأنا فى كودى اعتمدت على هذا النطاق لعمل مصنف لكل توجه موجود بهذا النطاق وبالتالى فى مخرجات كودى طلع مصنف التسويق 3 فارغ بدون أسماء

ليه ؟؟؟؟؟؟؟؟؟؟؟؟؟ لأن أصلا مفيش حد تم توجيهه الى التسويق 3

وأخوك ضليع جدا فى المعادلات وعايز معادلة فى النطاق "U12:U23" تاخذ من العمود S أسماء التوجهات النهائية بدون تكرار وتستثنى بدون توجيه

وبكده لا يظهر فى مخرجات كودى أى مصنف فارغ ياريت أكون واضح فى طلبى تحياتى لك

ياسر خليل أبو البراء · يوليو 24, 2015

أخي الحبيب مختار

بارك الله فيك وجزاك الله خير الجزاء

الكود الذي تفضلت به قمة في الروعة ويؤدي الغرض تماماً

بالنسبة لنقطة الاستثناء .. لو اطلعت على المرفقات في المشاركة رقم 5 لوجدت أنه في مصنف القوائم الكلية تم استثناء "بدون توجيه"

وأعتقد أن المصنف بدون توجيه لن يكون للأخ أشرف حاجة فيه ...

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

عموماً الحلين أمام الأخ أشرف فليختر ما يشاء والتنوع في الحلول يزيد الموضوع ثراءً

**مختار حسين محمود** · يوليو 24, 2015

أخى الكريم ياسر بارك الله فيك وجازاكم خيرا

طورت الكود بحيث يتم إنشاء مصنف لكل توجيه ويستثنى "بدون توجيه" ، كما يستثنى "بدون توجيه" في مصنف "قوائم التوجهات الكلية" ويصبح الكود بهذا الشكل :


Sub MOKHTARTSET2()

    Dim myDir As String, C As Range, WB As Workbook, NWB As Workbook, Rng1 As Range, Rng2 As Range
    
    Set WB = ThisWorkbook
    myDir = ActiveWorkbook.Path & "\" & "My Workbook"
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    On Error Resume Next
    MkDir myDir
    On Error GoTo 0
    
    '---------------------------------------------------------------------------------
    
        WB.Sheets("Final").Select
        
         Range("D7:S7").Select
         Selection.AutoFilter
         ActiveSheet.Range("$D$7:$S$27").AutoFilter Field:=16, Criteria1:="<>بدون توجيه", Operator:=xlAnd
        
        Columns("F:Q").Select
        Selection.EntireColumn.Hidden = True
        
        Set Rng1 = WB.Sheets("Final").Range("d7:s27").SpecialCells(xlCellTypeVisible)
        Rng1.Select
        Selection.Copy
        
        Set NWB = Workbooks.Add
        ActiveSheet.Range("A4").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
        
        Range("A4:D24").Select
        With Selection
        .HorizontalAlignment = xlCenter
        .Font.Size = 10
        .Font.Bold = True
        .Interior.ColorIndex = 38
        .Borders.LineStyle = xlContinuous
        End With
                
         ActiveSheet.Range("B2") = "قـــــوائم التوجهـــــــات الكلـــــية "
         
         NWB.SaveAs Filename:=myDir & "\" & "قـــــوائم التوجهـــــــات الكلـــــية " & ".xlsx", CreateBackup:=False
         NWB.Close
         
         WB.Activate
         WB.Sheets("Final").Cells.Select
         Selection.EntireColumn.Hidden = False
         Selection.AutoFilter
         Range("X11").Select
        
       '--------------------------------------------------------------------------------------
        For Each C In Sheets("Final").Range("U12:U23")
    
        WB.Sheets("Final").Range("AA1").Value = C.Value
        
        ' -------------------------------------------------------------------------------
               
         WB.Sheets("Final").Activate
         Range("D7:S7").Select
         Selection.AutoFilter
         
         ActiveSheet.Range("$S$11:$S$27").AutoFilter Field:=16, Criteria1:="<>بدون توجيه", Criteria2:="=" & C.Value, Operator:=xlAnd
         
         Range("F:Q,S:S").Select
         Selection.EntireColumn.Hidden = True
         
         Set Rng2 = WB.Sheets("Final").Range("D7:R27").SpecialCells(xlCellTypeVisible)
         Rng2.Select
         Selection.Copy
                 
         
         Set NWB = Workbooks.Add
         
         ActiveSheet.Range("A4").Select
         Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
         Application.CutCopyMode = False
        
         Range("A4:D10").Select
        
         With Selection
          .HorizontalAlignment = xlCenter
          .Font.Size = 10
          .Font.Bold = True
          .Borders.LineStyle = xlContinuous
          .Interior.ColorIndex = 38
         End With
                
         ActiveSheet.Range("B2") = "الموجهون الى"
         ActiveSheet.Range("C2") = C.Value
                  
         NWB.SaveAs Filename:=myDir & "\" & C.Value & ".xlsx", CreateBackup:=False
         NWB.Close
                  
         WB.Activate
         WB.Sheets("Final").Cells.Select
         Selection.EntireColumn.Hidden = False
         Selection.AutoFilter
         Range("A1").Select
        
        '-----------------------------------------------------------------------------------
        
   Next C
    
   
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub

أشكرك أستاذى العزيز .

Pupils Distribution According To Marks & Wishees by mokhtar v2 .rar

اشرف النعاس · يوليو 24, 2015

السلام عليكم ورحمة الله و بركاته
اولا شكر خاص للاخ ياسر و الاخ مختار على الحلول التي اعطيت للموضوع

الحقيقة اداء المنتدى اكتر من رائع و بالفعل الحل الذي قدمه الاخ ياسر في المشاركه 11 حيت اني لست بحاجة الى ملف فارغ في حالة عدم التنسيب و ايضا لا احتاج الى الطلبة الذين بدون توجيه اقرب شي الى طلبي و بارك الله فيك اخي ياسر و مختار
لدي طلب اريد فقط تعديل على ملفات المستخرجات بحيت يكون column width للترتيب 11 و column width للاسم و اللقب 28 و column width لل م.الترتيب 10.5
و ايضا Fill color تكون على حسب التخصص و ليس كما هيا موجودة حاليا حيت تتلون بالون الاصفر دائما و ايضا اريد حجم الخط هو 14 بدلا من 11
و شكرااااا

ياسر خليل أبو البراء · يوليو 24, 2015

أخي الكريم أشرف إليك الملف التالي فيه 90% مما طلبت

أما بالنسبة للتلوين لا أرى داعي لها حيث أن كل توجيه في مصنف مستقل الآن ..

قمت بحذف جميع التنسيقات الموجودة في المصنفات المصدرة

جرب الملف التالي وأعلمنا بالنتيجة

Export Workbooks Using Filter Method.rar

اشرف النعاس · يوليو 25, 2015

بارك الله فيك اخي ياسر تنسيق المخرجات اكتر من رائع

ياسر خليل أبو البراء · يوليو 25, 2015

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

منذ بدأ الموضوع لم نرى منك إعجاباً واحداً .. يوجد في أسفل كل مشاركة كلمة "أعجبني هذا" .. لن يكلفك الأمر جهداً ولا وقتاً إذا نقرت عليها

قدم الأخ مختار مشاركات رائعة تستحق الإعجاب وقدمت والحمد لله والفضل له وحده لا شريك له ، قدمت مشاركات أعتقد أنها أفادتك

يرجى الالتزام بالتوجيهات (راجع رابط التوجيهات جيداً)

لا تنسى أن تحدد أفضل إجابة ليظهر الموضوع مجاب ومنتهي

تقبل تحياتي

اشرف النعاس · يوليو 25, 2015

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

اخي ياسر اولا اعتدر منك و من الاخ مختار و من كل اسرة منتدنا الغالي .... لم اقم بالاعجاب لاني ليس على علم من قبل بوجود الاعجاب في المشاركة

و الان قمت بالاعجاب بكل المشاركات في هذا الموضوع ...... وفي النهاية اكرر شكري لك اخي ياسر و الاخ مختار و ايضا لكل اعضاء منتدنا الغالي.

تسجيل الدخول

انشاء ملف اكسل وفقا لشروط محدد

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

اشرف النعاس

أحمد مرجان

اشرف النعاس

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

اشرف النعاس

اشرف النعاس

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

اشرف النعاس

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

مختار حسين محمود

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

مختار حسين محمود

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

مختار حسين محمود

اشرف النعاس

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

اشرف النعاس

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

اشرف النعاس

Join the conversation

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

تصفح الموقع

تصفح جديد الموقع

Support

Important Information