تصفية اسماء حسب الشهر

[مهند الزيدي]

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

تصغية اسماء حسب الشهر.rar

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

أخي الكريم

هل الأسماء ستتكرر أكثر من مرة في ورقة العمل الواحدة أم أن الاسماء غير متكررة ؟

وهل هي نفس الأسماء في كل أوراق العمل ؟

يرجى مزيد من التفصيل

[مهند الزيدي]

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

[ابراهيم الحداد]

اخى الحبيب السلام عليكم

اليك الحل ولكن مع الاسف اضطررت لتغيير اسماء الشيتات الى اللغة الانجليزية

سأحاول فى وقت لاحق لايجاد حل واسماء الشيتات باللغة العربية

دمتم بـألف خير

تصغية اسماء حسب الشهر.rar

[مهند الزيدي]

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

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

أخي الكريم مهند

يرجى تغيير اسم الظهور للغة العربية

إليك الملف التالي فيه حل بالكود بدلاً من التعامل مع المعادلات التي تثقل الملف في حالة التعامل مع كم هائل من البيانات

أرجو أن يفي بالغرض

Sub GetData()
    Dim Col         As Long
    Dim Data        As Variant
    Dim Dict        As Object
    Dim N           As Long
    Dim Rng         As Range
    Dim Row         As Long
    Dim Table       As Variant
    Dim Wks         As Worksheet
    Dim Addr        As String
    
    Set Dict = CreateObject("Scripting.Dictionary")
    Dict.CompareMode = vbTextCompare
    
    ReDim Table(1 To 6, 1 To 1)
    
    For Each Wks In ThisWorkbook.Worksheets
        If Wks.Name <> "تصفية حسب الأشهر" Then
            Set Rng = Wks.Range("A1").CurrentRegion.Columns(2)
            Set Rng = Intersect(Rng, Rng.Offset(1, 0)).Resize(ColumnSize:=2)
            
            Col = Col + 1
            Data = Rng.Value
            Addr = Rng.Address
            
            For N = 1 To UBound(Data)
                If Not Dict.Exists(Data(N, 1)) Then
                    Row = Row + 1
                    Dict.Add Data(N, 1), Row
                    ReDim Preserve Table(1 To 6, 1 To Row)
                    Table(Col, Row) = Data(N, 2)
                Else
                    Table(Col, Dict(Data(N, 1))) = Data(N, 2)
                End If
            Next N
        End If
    Next Wks
    
    Table = Application.Transpose(Table)
    With Worksheets("تصفية حسب الأشهر")
        .Range("B2").Resize(Dict.Count, 1).Value = Application.Transpose(Dict.Keys)
        .Range("C2").Resize(UBound(Table, 1), UBound(Table, 2)).Value = Table
    End With
End Sub

تقبل تحياتي

 

Grab All Data From All Sheets YasserKhalil.rar

[محمد حسن المحمد]

الحمد لله وسلام على عباده الذين اصطفى

جزاكم الله خيراً أخي الحبيب أبو البراء

ما شاء الله بارك الله.

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

 

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

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

مرورك وردك أبي الغالي أبو يوسف تاج على رأسي

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

[محمد حسن المحمد]

الان, ياسر خليل أبو البراء said:

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

مرورك وردك أبي الغالي أبو يوسف تاج على رأسي

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

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

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

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

الحمد لله الذي رزقني بكم إخواني

فالدعاء بظهر الغيب يمنع عني المصائب الكبرى ويجلب لي الراحة النفسية

بارك الله فيكم وجزاكم الله خير الجزاء ، ولكم بمثل ما دعوتم إن شاء الله

[مهند الزيدي]

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

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

أخي الكريم

لا تنسى أن تغير اسم الظهور للغة العربي

جرب التعديل التالي ..

تم إضافة كود فرعي لعمل الطلب الجديد ألا وهو فرز البيانات بناءً على عمود الاسم ثم تم استدعاء الإجراء الفرعي داخل الكود الأساسي

Sub GetData()
    Dim Col         As Long
    Dim Data        As Variant
    Dim Dict        As Object
    Dim N           As Long
    Dim Rng         As Range
    Dim Row         As Long
    Dim Table       As Variant
    Dim Wks         As Worksheet
    Dim Addr        As String
    
    Set Dict = CreateObject("Scripting.Dictionary")
    Dict.CompareMode = vbTextCompare
    
    ReDim Table(1 To 6, 1 To 1)
    
    For Each Wks In ThisWorkbook.Worksheets
        If Wks.Name <> "تصفية حسب الأشهر" Then
            Set Rng = Wks.Range("A1").CurrentRegion.Columns(2)
            Set Rng = Intersect(Rng, Rng.Offset(1, 0)).Resize(ColumnSize:=2)
            
            Col = Col + 1
            Data = Rng.Value
            Addr = Rng.Address
            
            For N = 1 To UBound(Data)
                If Not Dict.Exists(Data(N, 1)) Then
                    Row = Row + 1
                    Dict.Add Data(N, 1), Row
                    ReDim Preserve Table(1 To 6, 1 To Row)
                    Table(Col, Row) = Data(N, 2)
                Else
                    Table(Col, Dict(Data(N, 1))) = Data(N, 2)
                End If
            Next N
        End If
    Next Wks
    
    Table = Application.Transpose(Table)
    With Worksheets("تصفية حسب الأشهر")
        .Range("B2").Resize(Dict.Count, 1).Value = Application.Transpose(Dict.Keys)
        .Range("C2").Resize(UBound(Table, 1), UBound(Table, 2)).Value = Table
    End With
    
    Call SortData
End Sub

Sub SortData()
    Dim WS As Worksheet
    Dim LR As Long
    Set WS = Sheets("تصفية حسب الأشهر")
    
    With WS
        LR = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("B1:H" & LR).Sort Key1:=.Range("B1:B" & LR), Order1:=xlAscending, Header:=xlYes
    End With
End Sub

تقبل تحياتي

 

[مهند الزيدي]

يعجز اللسان عن وصف الإبداع لك أخي العزيز "ياسر " وفقكم الله لكل خير 

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

أخي الكريم مهند

مصمم إنك متغيرش اسم الظهور للغة العربية وأنا وراك والزمن طويــــــــــــــــــــــــل (شفت الزمن طويل أد ايه)

وفقنا الله وإياك لما فيه الخير والصلاح للمسلمين

تقبل تحياتي

[مهند الزيدي]

آمين رب العالمين .. اشكرك اخي ياسر .. كيف يتم تغيير إسم الظهور .. حاولت ولم أستطع التغيير .. ممكن شرح بالخطوات.. وهل يؤثر إسم الظهور على إسم المسخدم

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

راجع رابط التوجيهات

اقتباس

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

** يتم تغيير اسم الظهور أو اسم المستخدم من خلال إعدادات الحساب ثم التبويب اسم المستخدم ، قم بتغيير الاسم ثم انقر كلمة حفظ

 

[مهند الزيدي]

أخي العزيز ياسر خليل وفقكم الله لكل خير ..

ممكن شرح الكود

Sub GetData()
    Dim Col         As Long
    Dim Data        As Variant
    Dim Dict        As Object
    Dim N           As Long
    Dim Rng         As Range
    Dim Row         As Long
    Dim Table       As Variant
    Dim Wks         As Worksheet
    Dim Addr        As String
    
    Set Dict = CreateObject("Scripting.Dictionary")
    Dict.CompareMode = vbTextCompare
    
    ReDim Table(1 To 6, 1 To 1)
    
    For Each Wks In ThisWorkbook.Worksheets
        If Wks.Name <> "تصفية حسب الأشهر" Then
            Set Rng = Wks.Range("A1").CurrentRegion.Columns(2)
            Set Rng = Intersect(Rng, Rng.Offset(1, 0)).Resize(ColumnSize:=2)
            
            Col = Col + 1
            Data = Rng.Value
            Addr = Rng.Address
            
            For N = 1 To UBound(Data)
                If Not Dict.Exists(Data(N, 1)) Then
                    Row = Row + 1
                    Dict.Add Data(N, 1), Row
                    ReDim Preserve Table(1 To 6, 1 To Row)
                    Table(Col, Row) = Data(N, 2)
                Else
                    Table(Col, Dict(Data(N, 1))) = Data(N, 2)
                End If
            Next N
        End If
    Next Wks
    
    Table = Application.Transpose(Table)
    With Worksheets("تصفية حسب الأشهر")
        .Range("B2").Resize(Dict.Count, 1).Value = Application.Transpose(Dict.Keys)
        .Range("C2").Resize(UBound(Table, 1), UBound(Table, 2)).Value = Table
    End With
End Sub

[نايف - م]

ما شاء الله

ما هذا الأبداع أستاذ ياسر

بارك الله فيك و بعملك و وفقك بكل عمل تقوم به

أنت رائع

 

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

أخي الكريم مهند

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

أعتذر وإن شاء الله نجد قريباً من يقدم على شرح هذه الموضوعات والتي من شأنها ستجعلنا نرتقي بإذن الله

تقبل تحياتي

[مهند الزيدي]

شكرا أخي العزيز ياسر خليل ..اتمنى أن لااكون أزعجتك .. وفقك الله لكل خير