اذهب الي المحتوي
أوفيسنا

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


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

أخي الكريم

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

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

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

رابط هذا التعليق
شارك

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

رابط هذا التعليق
شارك

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

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

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

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

تصغية اسماء حسب الشهر.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

  • Like 3
رابط هذا التعليق
شارك

الحمد لله وسلام على عباده الذين اصطفى
جزاكم الله خيراً أخي الحبيب أبو البراء

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

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

 

  • Like 1
رابط هذا التعليق
شارك

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

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

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

  • Like 1
رابط هذا التعليق
شارك

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

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

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

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

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

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

  • Like 1
رابط هذا التعليق
شارك

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

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

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

  • Like 1
رابط هذا التعليق
شارك

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

رابط هذا التعليق
شارك

أخي الكريم

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

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

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

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

تقبل تحياتي

 

  • Like 2
رابط هذا التعليق
شارك

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

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

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

تقبل تحياتي

رابط هذا التعليق
شارك

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

اقتباس

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

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

 

  • Like 1
رابط هذا التعليق
شارك

  • 1 month later...

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

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

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
رابط هذا التعليق
شارك

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

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

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

تقبل تحياتي

رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



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

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

Important Information