اذهب الي المحتوي
ليلى الهلالي

تمت الإجابة تعديل كود الترحيل ليتناسب مع ملفي

Recommended Posts

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

خواتم مباركة ومرضية

وجدت كود للأستاذ القدير ياسر خليل وأرجو منكم مساعدتي في معرفة المتغيرات أو الجزئيةأو ما يلزم لتغييره كي يتناسب مع ملفي. حيث أريد أن أرحل المعلمين من حافظة الدوام إلى ملف منفصل لكل مدرسة مع نسخ تنسيقات الحافظة.  والكود كالتالي

Sub Export_Workbooks_Using_Filter()
'Author  : YasserKhalil
'Release : 07 - 09 - 2016
'------------------------
    Dim a           As Variant
    Dim I           As Long
    Dim P           As Integer
    Dim cnt         As Integer
    Dim Dic         As Object
    Dim strDir      As String
    Dim Arr()       As Double
    Dim iFlag       As Boolean

    '=========================================================
    Const firstCol  As Long = 1             'First Column
    Const lastCol   As Long = 4             'Last Column
    Const colNo     As Long = 1             'Column To Filter
    Const sSheet    As String = "Sheet1"    'Sheet Name
    '=========================================================

    strDir = ThisWorkbook.Path & "\Output\"
    For P = firstCol To lastCol
        ReDim Preserve Arr(P - 1)
        Arr(P - 1) = Sheets(sSheet).Columns(P).ColumnWidth
    Next P
    iFlag = Sheets(sSheet).DisplayRightToLeft

    Call SpeedUp
        If Dir(strDir, vbDirectory) = "" Then MkDir strDir
    
        Sheets.Add before:=Sheets(1)
        Set Dic = CreateObject("Scripting.Dictionary")
        Dic.CompareMOde = 1
    
        With Sheets(sSheet).[A1].CurrentRegion
            .Columns(colNo).Value = Application.Trim(.Columns(colNo).Value)
            a = .Value
            .Parent.AutoFilterMode = False
    
            For I = 2 To UBound(a, 1)
                If Not Dic.exists(a(I, colNo)) And Not IsEmpty(a(I, colNo)) Then
                    Dic(a(I, colNo)) = Empty
                    .AutoFilter colNo, a(I, colNo)
                    .Copy Sheets(1).Cells(1)
                    Sheets(1).Copy
    
                    With ActiveWorkbook
                        With Sheets(1)
                            .Name = "Sheet1"
                            .DisplayRightToLeft = iFlag
                            .Cells(1).CurrentRegion.RowHeight = 19
                            For cnt = firstCol To lastCol
                                .Columns(cnt).ColumnWidth = Arr(cnt - 1)
                            Next cnt
                        End With
    
                        .SaveAs strDir & RemoveSpecial(CStr(a(I, colNo))) & ".xlsx"
                        .Close
                    End With
    
                    Sheets(1).Cells.Clear
                    .AutoFilter
                End If
            Next I
        End With
    
        Sheets(1).Delete
    Call SpeedDown

    MsgBox "Done...", 64
End Sub

Function RemoveSpecial(sInput As String) As String
    Dim sSpecialChars   As String
    Dim I               As Long

    sSpecialChars = "\/:*?""<>|"
    For I = 1 To Len(sSpecialChars)
        sInput = VBA.Trim(Replace$(sInput, Mid$(sSpecialChars, I, 1), " "))
    Next I

    RemoveSpecial = sInput
End Function

Function SpeedUp()
    With Application
        .Calculation = xlManual
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
    End With
End Function

Function SpeedDown()
    With Application
        .Calculation = xlAutomatic
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With
End Function

 

شارك هذه المشاركه


رابط المشاركه
شارك

وعليكم السلام -لابد من رفع ملف العمل حتى تتمكن الأساتذة من المساعدة

  • Like 1

شارك هذه المشاركه


رابط المشاركه
شارك

السلام عليكم

ارجو تجربة المرفق وقد تم مراعاة معظم المشاكل

لكن عليكي بان يكون القسم المدرج تحته البيانات مطابقا للعمل للتوضيح يجب ان

يكون العمل مادة القرآن الكريم وليس القران تحت قسم مادة القرآن الكريم

وقد تم عمل الملف بطريقة يسهل تعاملك معه بالرغم  من انه استغرق 3 ايام لفكرة صغيرة وهي كيفية التعرف علي الاقسام والصف الاخير في كل قسم

اخيرا بنفس طريقة عملك لهذا الملف صممي الملف الذي سيتم عليه عملك الفعلي والصقي نسحة فارغة من البيانات وليس من  الاقسام في شيت Source

فهو الشيت الذي يعتمد عليه لعمل نسخة لكل مدرسة

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

تحياتي

حافظة الدوام أوفيسنا.rar

  • Like 4

شارك هذه المشاركه


رابط المشاركه
شارك

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

شارك هذه المشاركه


رابط المشاركه
شارك

الأستاذ عادل حنفى

حفظه الله

رجل المهام الصعبة

شارك هذه المشاركه


رابط المشاركه
شارك

حبيبي يا جو مشكور علي مرورك

تحياتي

تم تعديل بواسطه عادل حنفي

شارك هذه المشاركه


رابط المشاركه
شارك

السلام عليكم

أستاذي الفاضل عادل حنفي

 بارك الله فيك

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

بارك الله فيك.png

شارك هذه المشاركه


رابط المشاركه
شارك
On 5/31/2019 at 4:42 AM, عادل حنفي said:

لكن عليكي بان يكون القسم المدرج تحته البيانات مطابقا للعمل للتوضيح يجب ان

يكون العمل مادة القرآن الكريم وليس القران تحت قسم مادة القرآن الكريم

أستاذي الفاضل. لم أفهم هذه النقطة حيث أن لدي ورقة البيانات الأصلية فيها تسميات المواد الدراسية قرآن، اسلامية،لغة عربية، لغة انجليزية وهكذا. ما فهمته أنني يجب أن أُعدل التسميات في ورقة العمل الأساسية وهذا صعب حيث أننا نقوم بعمل موحد ولا أستطيع تغيير التسميات التي اتقفنا على التعامل بها

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

 

القوى بالاكواد.rar

شارك هذه المشاركه


رابط المشاركه
شارك

السلام عليكم

الاخت ليلي

المقصود اعتقد انه بسيط ولكنه مهم فانه عند توزيع البيانات يتم المقارنه بين القسم (والمقصود به هنا البيان المكتوب في كل خلية مدمجة في شيت         حافظة الدوام كالاداريين ومادة القران الكريم وعام1-3(مربي).....وهكذا) وبين التخصص لكل موظف ويجب التطابق بينهما فاذا تم هذا الشرط فعند توزيع البيانات سينتقل الاسم تحت القسم المتطابق مع التخصص علما بان اي تخصص غير موجود له قسم سيتم انزاله تحت قسم الاداريين وانتي لن تغيري في تخصص كل موظف لا بل ستغيري في اسماء بنود الخلايا الدمجة فقط لتتطابق مع التخصص

وان استحال الامر ارسلي ملف يوضح التخصصات الغير متطابقة مع القسم كالتالي

القران        مادة القران الكريم وهكذا

ارجو اني استطعت ايصال المعلومة

تحياتي

شارك هذه المشاركه


رابط المشاركه
شارك

طبعا مع خالص تقدير للاستاذ الفاضل ياسر خليل فهو صديق عزيز ولكني لم اري الملف الذي يعمل كوده عليه وليس لدي من الوقت لقراءة كوده وتتبع عمله لذا كان لابد ومن الاسهل كتابة ما يتماشي مع مافهمته لملفك

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

Image3.jpg.94582810bf93d8f6df0311d0e52337b6.jpg

شارك هذه المشاركه


رابط المشاركه
شارك

السلام عليكم

كل عام وأنتم بخير وعيدكم مبارك

أعتذر لعدم الدخول سابقاً لظروف العيد

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

شارك هذه المشاركه


رابط المشاركه
شارك

السلام  عليكم

الاخت الفاضلة

اقتباس

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

هذا بالفعل ما اقصده المهم ان يكون  اسماء المواد هو نقسه الموجود بالخلايا المدمجة 

تم تعديل بواسطه عادل حنفي

شارك هذه المشاركه


رابط المشاركه
شارك

السلام عليكم

أستاذي الفاضل عادل

حاولت تغيير أسماء الخلايا المدمجة ولكن صادفني الآتي

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

وهذا أيضاً ينطبق على المواد العلمية(العلوم، كيمياء، فيزياء، أحياء) والاجتماعية( اجتماعيات، تاريخ، جغرافيا، المواد الفسلفية...... وغيرها) ففيها عدة مواد وجميعها تندرج تحت مسمى واحد

ولك جزيل الشكر.

شارك هذه المشاركه


رابط المشاركه
شارك

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 اعضاء متواجدين الان

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

×
×
  • اضف...