فصل الاقسام فى ملفات

[وائل عزالدين]

الساده الاعزاء علماء الاكسيل 

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

ممكن استاذن حضراتكم ف طلب بسيط

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

 

شكرا لسيادتكم

 

 

فصل الاقسام فى ملفات.rar

[أبوعيد]

الأقسام التي ذكرتها موجودة في أي عمود ؟ A أم B أم  C

[وائل عزالدين]

11 ساعات مضت, أبوعيد said:

الأقسام التي ذكرتها موجودة في أي عمود ؟ A أم B أم  C

الفاضل / أبوعيد

 العمود Description (B)

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

أخي الكريم وائل عز الدين

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

قم بإنشاء مجلد في نفس مسار المصنف باسم Output ثم ضع الكود التالي في موديول عادي ثم نفذ الكود ..

Sub Export_Workbooks_Using_Filter()
    Dim A, I As Long, Dic As Object

    Const colNo As Long = 2                 'Column Number
    Const sSheet As String = "MySheet"      'Sheet Name

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
        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 = AlphaNumericOnly(CStr(A(I, colNo)))
                            .DisplayRightToLeft = False
                            .Columns.AutoFit
                        End With
    
                        .SaveAs ThisWorkbook.Path & "\Output\" & AlphaNumericOnly(CStr(A(I, colNo))) & ".xlsx"
                        .Close
                    End With
    
                    Sheets(1).Cells.Clear
                    .AutoFilter
                End If
            Next
        End With
    With Application
        Sheets(1).Delete
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With

    MsgBox "Done...", 64
End Sub

Function AlphaNumericOnly(strSource As String) As String
    Dim I As Integer
    Dim strResult As String

    For I = 1 To Len(strSource)
        Select Case Asc(Mid(strSource, I, 1))
            Case 48 To 57, 65 To 90, 97 To 122, 32
                strResult = strResult & Mid(strSource, I, 1)
        End Select
    Next I

    If Len(strResult) > 31 Then strResult = Mid(strResult, 1, 31)
    AlphaNumericOnly = Application.WorksheetFunction.Trim(strResult)
End Function

تقبل تحياتي

[وائل عزالدين]

استاذنا ياسر خليل أبو البراء

بعد التحيه انا بتأسف لسيادتك جدا جدا ع التعب

وبشكرك جدا جدا ع جهدك الواضح دا

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

[omar elhosseini]

 

بعد اذن اخونا العزيز ياسر خليل أبو البراء

 

استبدل السطر

Const sSheet As String = "MySheet"      'Sheet Name

بهذا

Const sSheet As String = "Sheet3"

 

الاخ وائل عزالدين

شاهد المرفق

 

فصل الاقسام فى ملفات.rar

 

تعليمات التشغيل

لا تقوم بإنشاء فلدر للملفات

الملفات المنتجة لم يتم ازالة اي احرف منها

فهي بنفس المسميات

 

 

تم تعديل أغسطس 30, 2016 بواسطه عمر الحسيني

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

أخي وحبيبي ومعلمي عمر الحسيني

ملف رائع ومبدع كالعادة ...

بعد مشاركتك الأخيرة قمت بالتعديل مرة أخرى على الكود لأسهل على الأخ السائل المسألة ..

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

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

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

بينما الكود الخاص بي سيتستخرج 33 ملف ..

المصنف المفقود بالنسبة إليك هو A399 وهو بالشكل التالي

QMS&HSE : Quality Management System & Health, Safety

لاحظ النص وفيه العلامة : ، وطبعاً بسبب استخدام سطر تخطي الخطأ حدث خطأ وتخطى هذا المصنف ولم ينشأ له مصنف ....

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

كان من الممكن أن أعالج الكود الذي قدمته باستخدام الدالة Replace ونستبدل علامة : بـ "" لا شيء وتمر المشكلة بسلام ويتم إنشاء الملف بدون مشاكل وتنتهي قضية الموضوع ..

ولكني أحب أن أتعامل مع المشكلة بشكل أعم وأشمل ، وأعتقد أنك تقوم بذلك بالفعل وهذا ما يعجبني فيك كثيراً

 

أمر آخر وهو الاستعانة بورقة العمل في تنفيذ المهمة ..هذا أمر لا أستحبه كثيراً وإن فعلت أقوم بالتخلص من المخلفات أي أقوم بحذف الأعمدة التي تم استخدامها

أعتذر عن الإطاله في المشاركة ولكن وجبت المناقشة للوصول لأفضل الحلول

 

 

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

Const sSheet As String = "MySheet"      'Sheet Name

أي قمت بتغيير النص MySheet إلى Sheet3 .. حسب الملف المرفق في المشاركة الأولى

 

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

Sub Export_Workbooks_Using_Filter()
    Dim a, I As Long, Dic As Object
    Dim strDir As String

    Const colNo As Long = 2                 'Column Number
    Const sSheet As String = "MySheet"      'Sheet Name
    strDir = ThisWorkbook.Path & "\Output\"

    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)
                            .DisplayRightToLeft = False
                            .Columns.AutoFit
                        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

تقبلوا تحياتي

[أبوبسمله]

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

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

الان, أحمد الفلاحجى said:

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

ربنا يبارك فيك يا فلاحجي وعوداً حميداً .. المنتدى نور بعودتك

تقبل وافر تقديري واحترامي

[أبوبسمله]

ده منور باحبابى وخلانى

وفقكم الله اجمعين

[وائل عزالدين]

2 ساعات مضت, عمر الحسيني said:

 

بعد اذن اخونا العزيز ياسر خليل أبو البراء

 

استبدل السطر

Const sSheet As String = "MySheet"      'Sheet Name

بهذا

Const sSheet As String = "Sheet3"

 

الاخ وائل عزالدين

شاهد المرفق

 

فصل الاقسام فى ملفات.rar

 

تعليمات التشغيل

لا تقوم بإنشاء فلدر للملفات

الملفات المنتجة لم يتم ازالة اي احرف منها

فهي بنفس المسميات

 

 

استاذ عمر الحسيني

شاكر جدا جدا لجهدك العظيم المبذول

كنت عايز اعرف مكان حفظ الملفات

لم يتم العثور عليها

 

شكرا

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

أخي الكريم ..مسار الملفات في نفس مسار المصنف الحالي الذي يحتوي الكود ...

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

وكذلك الحال بالنسبة لكود العلامة أبو تامر في نفس المسار في مجلد اسمه "الأقسام_1" وإذا كررت الكود سيتم إنشاء مجلد جديد باسم "الأقسام_2"

 

[وائل عزالدين]

3 دقائق مضت, ياسر خليل أبو البراء said:

أخي الكريم ..مسار الملفات في نفس مسار المصنف الحالي الذي يحتوي الكود ...

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

وكذلك الحال بالنسبة لكود العلامة أبو تامر في نفس المسار في مجلد اسمه "الأقسام_1" وإذا كررت الكود سيتم إنشاء مجلد جديد باسم "الأقسام_2"

 

بارك الله فيكم جميعا

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

[omar elhosseini]

 

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

 

ادعو لفاتح الطريق

العتب علي النظر الضعيف

الاكسيل عند عربي لم الحظ ال 2 من 3

في اللغة العربية

 

الاخ وائل عزالدين

المرفق بعد التصحيح

فصل الاقسام فى ملفات_2.rar

 

 

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

بارك الله فيك معلمي الكبير أبو تامر ولا حرمنا الله منك ..