نقل بيانات من عمودية لافقية بخطوة واحدة

[ربا]

السلام عليكم اصدقائي

انا بحاجة لمساعدتكم لتقل بيانات من الصفحة الاولى الى الصفحة الثانية وقد جربت جميع الطرق و من بينها pivot table ولم انجح والمراد أن البيانات التي بالصفحة الاولى كما بالمثال اريد نقلها وفق الترتيب بالصفحة الاخرى بطريقة افقية 

مع الشكر الجزيل

test 000.rar

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

وعليكم السلام

قومي بتنسيق أعمدة ورقة النتائج كنص من خلال كليك يمين على خلايا ورقة العمل ثم اختاري Format Cells ثم اختاري Text ثم جربي الكود التالي 

Sub Test()
    Dim coll As New Collection, arr, maxItem As Long, i As Long, j As Long, str1 As String, v1, v2

    arr = Sheets("Sheet1").Range("A1").CurrentRegion.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 CStr(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

    Sheets("Sheet2").Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End Sub

 

[ربا]

منذ ساعه, ياسر خليل أبو البراء said:

وعليكم السلام

قومي بتنسيق أعمدة ورقة النتائج كنص من خلال كليك يمين على خلايا ورقة العمل ثم اختاري Format Cells ثم اختاري Text ثم جربي الكود التالي 

Sub Test()
    Dim coll As New Collection, arr, maxItem As Long, i As Long, j As Long, str1 As String, v1, v2

    arr = Sheets("Sheet1").Range("A1").CurrentRegion.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 CStr(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

    Sheets("Sheet2").Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End Sub

 

حاولت ولم تزبط . هل يوجد طريقة اسهل 

منذ ساعه, ياسر خليل أبو البراء said:

وعليكم السلام

قومي بتنسيق أعمدة ورقة النتائج كنص من خلال كليك يمين على خلايا ورقة العمل ثم اختاري Format Cells ثم اختاري Text ثم جربي الكود التالي 

Sub Test()
    Dim coll As New Collection, arr, maxItem As Long, i As Long, j As Long, str1 As String, v1, v2

    arr = Sheets("Sheet1").Range("A1").CurrentRegion.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 CStr(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

    Sheets("Sheet2").Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End Sub

 

 

منذ ساعه, ربا said:

حاولت ولم تزبط . هل يوجد طريقة اسهل 

 

 

[ربا]

عملت جميع الخلايا text وعند نقل الكود يعلق على range

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

يتم وضع الكود في محرر الأكواد في موديول جديد .. شاهدي الفيديو التالي لتعرفي أساسيات التعامل مع الأكواد

 

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

 

Sample.rar

[ربا]

انا غلبتك معاي بس هادا شي بالنسبة لالي صعب لو في اي طريقة غير هذا يا ريت 

وشكرااااااااااااااااااااااااااااااااااااااااااااااااااااا

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

أرفقت ملف مرفق .. هل قمتي بتجربة الملف المرفق؟

[ربا]

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

[خالد الرشيدى]

السلام عليكم

بعد اذن استاذي القدير / أبو البراء

اعتقد مع كثرة البيانات سيكون الكود الذي ادرجة استاذي ابو البراء جزاه الله عنا خيراً  هو الخيار الافضل  - ومع ذلك اليك حل اخر بالمعادلات 

test 000_2.rar

=IFERROR(INDEX(Sheet1!$B$2:$B$1000,SMALL(IF(Sheet1!$A$2:$A$1000=$A2,ROW($A$2:$A$1000)-ROW($A$2)+1),COLUMN(A1))),"")

 

تم تعديل يونيو 7, 2017 بواسطه خالد الرشيدى

[ربا]

1 ساعه مضت, خالد الرشيدى said:

السلام عليكم

بعد اذن استاذي القدير / أبو البراء

اعتقد مع كثرة البيانات سيكون الكود الذي ادرجة استاذي ابو البراء جزاه الله عنا خيراً  هو الخيار الافضل  - ومع ذلك اليك حل اخر بالمعادلات 

test 000_2.rar

=IFERROR(INDEX(Sheet1!$B$2:$B$1000,SMALL(IF(Sheet1!$A$2:$A$1000=$A2,ROW($A$2:$A$1000)-ROW($A$2)+1),COLUMN(A1))),"")

 

 

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

أختي القاضلة

جربي بعد اذنك هذا الملف (صفحة Salim)

 

test 000 Salim.rar