تحويل جزأ من خلايا العمود الى صفوف لتنسيق البيانات

[alsihran]

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

بالمرفق ملف

يحتوي على صفوف واعمدة 

المشكلة : 

كل 14 صف في الواقع هو صف واحد لأن هناك بعض القيم مكررة 

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

 

المطلوب : 

الاحتفاظ بقيمة واحده من العمود A المتضمن عنوان Code

الاحتفاظ بقيمة واحده من العمود B المتضمن عنوان date1

وهكذا لبقية الاعمدة C :D 

تحويل قيم الخلايا في العمود E من الخلية رقم E2 الى E14 الى صفوف بدون تكرار 

وادراج القيم من العمود F اسفل منها 

للحصول على  هذه النتيجة لجميع السجلات حسب شرح الصورة 

أمل الاخذ في الحسبان ان عدد الاعمدة في الجدول الاساسي  تقريبا 31 عمود والملف المرفق هذا اضعه كمثال بسبب وجود بيانات حساسه 

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

لأنه في كل يوم يأتيني ملف  به ما يقارب اربع وعشرون  الف صف وتحويلها يدوي متعب ويحتمل الخطأ

ارجو ان اكون استطيعت شرح المطلوب بصورة واضحه 

 

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

[محي الدين ابو البشر]

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

ربما

 

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

تم تعديل فبراير 25, 2023 بواسطه محي الدين ابو البشر

[alsihran]

4 ساعات مضت, محي الدين ابو البشر said:

ربما

شكرا لك أخي الكريم 

النتيجة صحيحة حسب المرفق وهو مثال 

حاولت تطبيق المثال على الملف الفعلي 

وهو يحتوي على 35 عامود لكن فشلت المحاولة وظهرت هذه الرسالة عند تشغيل  Macro1

 

 

 

وعند تشغيل المايكرو test

يتم اضافة 4 اعمدة فقط في الورقة رقم 2

استاذي الكريم هلا تلطفت وشرحت لي خطوة بخطوة الية عمل المايكرو  Macro1 والمايكرو test

وما هو المطلوب تعديلة في الكود لاضافة بقية الاعمدة 

شاكر ومقدر لك مساعدتك وحسن تعاونك 

 

[lionheart]

The right procedure is Test not Macro1

[محي الدين ابو البشر]

تفضل أخي الكريم

استبدل باكود:

Sub test()
Dim a
a = Sheets(1).Cells.CurrentRegion
With CreateObject("scripting.dictionary")
                For i = 2 To UBound(a)
                    If Not .exists(a(i, 1)) Then
                 .Add a(i, 1), Array(Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4)), Array(a(i, 5), a(i, 6)))
            Else
         w = .Item(a(i, 1))
       w(1)(0) = w(1)(0) & "|" & a(i, 5)
        w(1)(1) = w(1)(1) & "|" & a(i, 6)
        .Item(a(i, 1)) = w
              End If
            Next
            itm = .items
           For i = 0 To .Count - 1
   Sheets(2).Cells(i + 2, 1).Resize(, 4) = .items()(i)(0)
   Sheets(2).Cells(i + 2, 1).Offset(, 4) = .items()(i)(1)(1)
    Next
    Application.DisplayAlerts = False
    Sheets(2).Cells(2, 5).Resize(.Count).TextToColumns Destination:=Sheets(2).Cells(2, 5), DataType:=xlDelimited, _
      Other:=True, OtherChar:="|", FieldInfo:=Array(UBound(a, 2) - 4, 1), TrailingMinusNumbers:=True
      Application.DisplayAlerts = True
End With
End Sub

 

[alsihran]

18 دقائق مضت, محي الدين ابو البشر said:

تفضل أخي الكريم

استبدل باكود:

الله يجزاك خير استاذي 

يبدو أني لم اوصل الفكرة بشل جيد 

الكود الاول الذي عملته يعمل بشكل جيد 

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

لو افترضنا ان هناك اعمدة بنفس طريقة العمود  E , F  وهنا نضرب المثال بالعمود  G و  H 

فكيف سيكون شكل المصفوفة لاضافتها للورقة الثانية 

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

ان لم تكن الفكرة وصلت سأضيف مرفق اخر للتطبيق عليه 

او ارسل لك الملف على بشكل خاص لاحتوائه على معلومات حساسة 

 

[محي الدين ابو البشر]

بصراحة لم تصل الفكرة تماما

بالإضافة إلى E , F تريد  G و  H؟

!!!

بليز

[alsihran]

3 دقائق مضت, محي الدين ابو البشر said:

بالإضافة إلى E , F تريد  G و  H؟

نعم استاذ 

اريد اضافة اعمدة جديد بنفس طريقة العمودين E و F 

 

 

3 دقائق مضت, محي الدين ابو البشر said:

بليز

🍁

[محي الدين ابو البشر]

هكذا؟

Sub test()
Dim a
a = Sheets(1).Cells.CurrentRegion
With CreateObject("scripting.dictionary")
                For i = 2 To UBound(a)
                    If Not .exists(a(i, 1)) Then
                 .Add a(i, 1), Array(Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4)), Array(a(i, 5), a(i, 6), a(i, 7), a(i, 8)))
            Else
         w = .Item(a(i, 1))
       w(1)(0) = w(1)(0) & "|" & a(i, 5)
        w(1)(1) = w(1)(1) & "|" & a(i, 6) & "|" & a(i, 7) & "|" & a(i, 8)
       .Item(a(i, 1)) = w
              End If
            Next
           For i = 0 To .Count - 1
   Sheets(2).Cells(i + 2, 1).Resize(, 4) = .items()(i)(0)
   Sheets(2).Cells(i + 2, 1).Offset(, 4) = .items()(i)(1)(1)
    Next
    Application.DisplayAlerts = False
    Sheets(2).Cells(2, 5).Resize(.Count).TextToColumns Destination:=Sheets(2).Cells(2, 5), DataType:=xlDelimited, _
      Other:=True, OtherChar:="|", FieldInfo:=Array(14, 1), TrailingMinusNumbers:=True
      Application.DisplayAlerts = True
End With
End Sub

اذا  لم يكن المطلوب

أرجو أن ترفق ملف فيه النتائج المتوقعة

شكراً

تم تعديل فبراير 26, 2023 بواسطه محي الدين ابو البشر

[alsihran]

5 ساعات مضت, محي الدين ابو البشر said:

اذا  لم يكن المطلوب

أشكرك استاذي الكريم 

لقد أتعبتك معي 

بطريقة ما توصلت الى نتيجة مقبولة من خلال الكود الاول 

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

[محي الدين ابو البشر]

 لا تعب

هل من الممكن عرض ما توصلت إلية؟

لللإفادة

[alsihran]

23 ساعات مضت, محي الدين ابو البشر said:

هل من الممكن عرض ما توصلت إلية؟

لللإفادة

لم أقم بعمل اي شيئ اضافي فقط اضفة بعض الاعمدة 

Sub test()
Dim a
a = Sheets(1).Cells.CurrentRegion
With CreateObject("scripting.dictionary")
                For i = 2 To UBound(a)
                    If Not .exists(a(i, 1)) Then
                 .Add a(i, 1), Array(Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4), a(i, 5), a(i, 6), _
                 a(i, 7), a(i, 8), a(i, 9), a(i, 10), a(i, 11), a(i, 12), a(i, 13), a(i, 14), a(i, 15), _
                 a(i, 16), a(i, 17), a(i, 18), a(i, 19), a(i, 20), a(i, 21), a(i, 22), a(i, 23), _
                 a(i, 24), a(i, 25), a(i, 26), a(i, 27)), Array(a(i, 28), a(i, 29)))
            Else
         w = .Item(a(i, 1))
       w(1)(0) = w(1)(0) & "|" & a(i, 28)
        w(1)(1) = w(1)(1) & "|" & a(i, 29)
        .Item(a(i, 1)) = w
              End If
            Next
            itm = .items
           For i = 0 To .Count - 1
   Sheets(2).Cells(i + 2, 1).Resize(, 27) = .items()(i)(0)
   Sheets(2).Cells(i + 2, 1).Offset(, 27) = .items()(i)(1)(1)
    Next
    Application.DisplayAlerts = False
    Sheets(2).Cells(2, 28).Resize(.Count).TextToColumns Destination:=Sheets(2).Cells(2, 28), DataType:=xlDelimited, _
      Other:=True, OtherChar:="|", FieldInfo:=Array(14, 1), TrailingMinusNumbers:=True
      Application.DisplayAlerts = True
End With
End Sub

 

[محي الدين ابو البشر]

يمكن اختصار

 .Add a(i, 1), Array(Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4), a(i, 5), a(i, 6), _
                 a(i, 7), a(i, 8), a(i, 9), a(i, 10), a(i, 11), a(i, 12), a(i, 13), a(i, 14), a(i, 15), _
                 a(i, 16), a(i, 17), a(i, 18), a(i, 19), a(i, 20), a(i, 21), a(i, 22), a(i, 23), _
                 a(i, 24), a(i, 25), a(i, 26), a(i, 27)), Array(a(i, 28), a(i, 29)))

إلى

  .Add a(i, 1), Array(Application.Transpose(Application.Index(a, i, Evaluate("row(1:" & UBound(a, 2) - 2 & ")"))), _
                                                     Array(a(i, UBound(a, 2) - 1), a(i, UBound(a, 2))))

 

 

Sub test()
Dim a, aa, w
Dim i&
a = Sheets(1).Cells.CurrentRegion
With CreateObject("scripting.dictionary")
                For i = 2 To UBound(a)
                     If Not .exists(a(i, 1)) Then
                  .Add a(i, 1), Array(Application.Transpose(Application.Index(a, i, Evaluate("row(1:" & UBound(a, 2) - 2 & ")"))), _
                                                     Array(a(i, UBound(a, 2) - 1), a(i, UBound(a, 2))))
            Else
         w = .Item(a(i, 1))
       w(1)(0) = w(1)(0) & "|" & a(i, UBound(a, 2) - 1)
        w(1)(1) = w(1)(1) & "|" & a(i, UBound(a, 2))
       .Item(a(i, 1)) = w
              End If
            Next
           For i = 0 To .Count - 1
   Sheets(2).Cells(i + 2, 1).Resize(, 4) = .items()(i)(0)
   Sheets(2).Cells(i + 2, 1).Offset(, 4) = .items()(i)(1)(1)
    Next
    Application.DisplayAlerts = False
    Sheets(2).Cells(2, 5).Resize(.Count).TextToColumns Destination:=Sheets(2).Cells(2, 5), DataType:=xlDelimited, _
      Other:=True, OtherChar:="|", FieldInfo:=Array(14, 1), TrailingMinusNumbers:=True
      Application.DisplayAlerts = True
End With
End Sub

 

تم تعديل فبراير 28, 2023 بواسطه محي الدين ابو البشر