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

[ام ناصر]

السلام عليكم ..

لدي استفسار عن كيفية تحويل حقل يحتوي على مجموعة من البيانات وفق حقل اخر يحتوي على (ID) خاص بتلك البيانات الى اسطر متعددة اعتماداً على هذا الـ (ID) كما موضح في الصورة المدرجة ، علما ان البيانات تفوق ال1000 سطر وطريقة تحويلها بأستخدام (Transpose) لاتؤدي الغرض المطلوب ،أضافةً لأستغراقها وقت كبير ، ارجوا المساعدة في حل هذه المشكلة ولكم جزيل الشكر .مرفق الصورة وملف الاكسل كنموذج مبسط مدرج في ادناه

T1.xlsx

[lionheart]

Sub Test()
    Dim a, i As Long, ii As Long, t As Long
    a = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 2).Value
    a(1, 2) = a(1, 2) & " 1"
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            If Not .Exists(a(i, 1)) Then
                .Item(a(i, 1)) = Array(.Count + 2, 2)
                For ii = 1 To 2
                    a(.Count + 1, ii) = a(i, ii)
                Next ii
            Else
                t = .Item(a(i, 1))(1) + 1
                If UBound(a, 2) < t Then
                    ReDim Preserve a(1 To UBound(a, 1), 1 To t)
                    a(1, t) = Replace(a(1, 2), "1", t - 1)
                End If
                a(.Item(a(i, 1))(0), t) = a(i, 2)
                .Item(a(i, 1)) = Array(.Item(a(i, 1))(0), t)
            End If
        Next i
        t = .Count + 1
    End With
    With Sheets("Sheet2").Cells(1).Resize(t, UBound(a, 2))
        .CurrentRegion.Clear
        .Value = a: .Borders.Weight = 2
        .HorizontalAlignment = xlCenter
        .Columns.AutoFit
        .Parent.Select
    End With
End Sub

 

[ام ناصر]

اخي الكريم  جزاك الله خير للرد، ممكن اعرف اين اضع هذه الدالة ؟
لاني مو متمرسة في الاكسل

[lionheart]

Press Alt + F11 to open VBE editor > from Insert menu > Select Module > Paste the code I posted

To run the code, press F5 when in VBE editor or go back to the worksheet and press Alt + F8 then select the macro name and finally click Run

[ام ناصر]

سلمت الایادي استاذ ،
كيف ممكن ان اغير الكود من ثلاث اعمدة وليس من عمودين ؟
جربت اغير بالكود مانفع 

[lionheart]

Attach a new file with some data and the new output

[ام ناصر]

 عفواً استاذ ،
تم رفع الملف يحتوي المثال والنتيجة المطلوبة  

T2.xlsx

[lionheart]

Sub Test()
    Dim a, tmp, i As Long, ii As Long, t As Long
    a = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 3).Value
    a(1, 3) = a(1, 2) & " 1"
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            If Not .Exists(a(i, 1)) Then
                .Item(a(i, 1)) = Array(.Count + 2, 3)
                tmp = a(i, 2)
                a(.Count + 1, 1) = a(i, 1)
                a(.Count + 1, 2) = a(i, 3)
                a(.Count + 1, 3) = tmp
            Else
                t = .Item(a(i, 1))(1) + 1
                If UBound(a, 2) < t Then
                    ReDim Preserve a(1 To UBound(a, 1), 1 To t)
                    a(1, t) = Replace(a(1, 3), "1", t - 2)
                End If
                a(.Item(a(i, 1))(0), t) = a(i, 2)
                .Item(a(i, 1)) = Array(.Item(a(i, 1))(0), t)
            End If
        Next i
        t = .Count + 1
    End With
    a(1, 2) = "Date"
    With Sheets("Sheet2").Cells(1).Resize(t, UBound(a, 2))
        .CurrentRegion.Clear
        .Value = a: .Borders.Weight = 2
        .HorizontalAlignment = xlCenter
        .Columns.AutoFit
        .Parent.Select
    End With
End Sub

 

[ام ناصر]

سلمت الایادي استاذ ربي يبارك بجهودك الطيبة 

هل من الممكن ان يكون ذات الكود بجملة الـ SQl ؟

[lionheart]

I think that's enough for this question. You can review this link