طلب تعديل كود جلب بيانات للأستاذ ياسرخليل ابو البراء

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

أخي الكريم ناصر

إليك الملف المرفق فيه طلبك

Grab Data Using Arrays.rar

[ناصرالمصرى]

اخى الفاضل ايو البراء

حياكم الله وبارك فيكم

ارجو التفضل بمتابعة الملف المرفق

علما بأنىى إطلعت على موضوعك المميز 

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

http://www.officena.net/ib/topic/56521-المصفوفات-في-الإكسيل-arrays/

ولكن هناك من الامور التى لم أستوعبها حتى الان 

أرجو التعديل فضلا أخى الكريم كما فى المرفق  ***** بارك الله فيك وبإنتظار ردكم

Grab Data Using Arrays.rar

[ناصرالمصرى]

للرفع

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

أخي الكريم ناصر

يفضل دائماً وضع الملف المرفق المعبر عن الملف الأصلي من البداية حتى لا يطول الموضوع بدون داعي

كما يفضل أن يكون الطلب واضح تماماً مع توضيح تفاصيل الملف بالكامل .. لأن الأكواد حساسة جداً لكل تفصيلة

عموماً إليك الكود التالي وإن شاء الله يفي بالغرض

Sub Test()
    Dim Col As New Collection, Arr, I As Long, J As Long
    On Error Resume Next

    Arr = Sheet1.Range("A7:J" & Sheet1.Cells(Rows.Count, "A").End(xlUp).Row).Value
    For I = 2 To UBound(Arr, 1)
        For J = 2 To UBound(Arr, 2)
            Col.Add Key:=J & Chr(2) & Arr(I, 1), Item:=Arr(I, J)
        Next J
    Next I

    With Sheet2.Range("A7:J" & Sheet2.Cells(Rows.Count, "A").End(xlUp).Row)
        Arr = .Value
        For I = 2 To UBound(Arr, 1)
            For J = 2 To UBound(Arr, 2)
                Arr(I, J) = Col(J & Chr(2) & Arr(I, 1))
            Next J
        Next I
        .Value = Arr
    End With
End Sub

أرجو أن يكون المطلوب إن شاء الله

تقبل تحياتي

[ناصرالمصرى]

أخى الفاضل الاستاذ ياسر خليل

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

هو بالفعل الملف معبر للملف الاصلى ولكن لن أتوقع ان يكون

بإستخدام المصفوفات التى هى محل دراسة الان 

شاكر لك حسن صنعيك وبارك فيكم

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