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

[الغواص العربي]

الاساتذة الفضلاء  وفقهم الله

اطلب مساعدتكم في حل المشكلة وهي كالتالي:

يوجد بنود متكررة بسبب قيم مرتبطه بها، مثال:

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

معرف الحساب	رقم الفاتورة
0042822222	004288639319
0042822222	004288789594
0042822222	004283215584
0042822222	004280492485
0047233333	004726724529
0047233333	004724802570
0052233333	005220167807
0052233333	005221449659
0052233333	005224827945
0052233333	005229599469
0052233333	005224309277
0052233333	005223848932
0052233333	005221427177
0052233333	005221404179
0053312222	005332331258
0053312222	005336979664
0053312222	005338257360
0053312222	005330520251
0078112222	007818900303
0078112222	007813572684

[سليم حاصبيا]

=IF($A1<>$A2,$A2,"")

ارفع الملف نفسه وليس صورة عنه

على كل حال لنفرض ان معرف الحساب موجود في العامود A ابتداءً من الخلية A2

اكتب هذه المهادلة في اي عامود ابتداءً من الصف 2 واسحب نزولاً

 

 

تم تعديل أغسطس 12, 2016 بواسطه سليم حاصبيا

[الغواص العربي]

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

[الغواص العربي]

لم تنجح العملية تم ارفاق الملف............. جزاك الله خير اخي.

معرفات مكررة بفواتير مختلفة.rar

[Guest محمد ابو صهيب]

[الغواص العربي]

اخي محمد ابوصهيب   جزاك الله خير 

ولكن حذف المكرر بهذا الامر لايحل الاشكال،

المطلوب بعد حذف المكرر   هو وضع المعرف الفريد في عامود وفواتيره في اعمدة بجواره

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

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

مرفق صورة

[سليم حاصبيا]

جرب هذا الملف

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

و ستلاحظ ان كل شيء يتغير

معرفات مكررة بفواتير مختلفة salim.rar

تم تعديل أغسطس 12, 2016 بواسطه سليم حاصبيا

[الغواص العربي]

جزالك الله خير اخي سليم حاصبيا  على تعبك 

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

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

[سليم حاصبيا]

لا اعرف اذا كان هذا ما تقصده بالضبط

تم جماية الخلايا التي تحتوي على معادلات لعدم العبث لها عن طريق الخطأ

وتم ايضاً توسيع النطاق ليشمل 200 صف

معرفات مكررة بفواتير مختلفة salim1.rar

[الغواص العربي]

جزاك الله خير اخي على مجهودك

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

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

[سليم حاصبيا]

تم التعديل على الملف حسب ما تريد

انظر الى الصفحة salim

معرفات مكررة بفواتير مختلفة salim2.rar

[الغواص العربي]

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

اخي سليم حاصبيا 

قمة الابداع ملف اكثر من المطلوب وزيادة .............. بارك الله فيك وفي علمك .................. صدق فيك قائل المثل رب اخي لك لم تلدة امك.

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

أخي الحبيب سليم

بارك الله فيك وجزيت خيراً على أعمالك الممتازة

إثراءً للموضوع .. إليك الكود التالي (قم بتنسيق الخلايا التي ستظهر فيها النتائج كنص)

Sub Test()
    Dim Coll As New Collection, arr, maxItem As Long, I As Long, J As Long, str1 As String, V1, V2

    arr = Range("A1:B" & Cells(Rows.Count, 1).End(xlUp).Row).Value

    For I = 1 To UBound(arr, 1)
        str1 = CStr(arr(I, 1))
        
        On Error Resume Next
            Coll.Add Key:=str1, Item:=New Collection
        On Error GoTo 0
        
        If Coll(str1).Count = 0 Then Coll(str1).Add str1
        For J = 2 To UBound(arr, 2)
            If Len(arr(I, J)) Then Coll(str1).Add arr(I, J)
        Next J
    Next I
    
    For Each V1 In Coll
        If V1.Count > maxItem Then maxItem = V1.Count
    Next V1
    
    ReDim arr(1 To Coll.Count, 1 To maxItem)
    I = 0
    For Each V1 In Coll
        I = I + 1
        J = 0
        For Each V2 In V1
            J = J + 1
            arr(I, J) = V2
        Next V2
    Next V1
    
    For J = 2 To maxItem
        arr(1, J) = J - 1
    Next J

    Range("F1").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End Sub

تقبل تحياتي

 

[الغواص العربي]

جزاكم الله خير اخواني في الله ..