نقل بيانات من اعمدة الى صفوف

[شبل ليث]

السلام عليكم اعضاء المنتدى الكرام

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

اطفال.xlsx

[مهند محسن]

وعليكم السلام ..جرب هذا

كيفية نقل البيانات من العمود (الأعمدة) إلى الصف (الصفوف) أو العكس في Excel؟

[شبل ليث]

السلام عليكم

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

والملف المرفق

اطفال.xlsx

[محمد هشام.]

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

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

اطفال(3).xlsx

[شبل ليث]

شكرا للاستاذ محمد هشام على تعاونك معي وعلى مساعدتي جعله الله في ميزان حسناتك

اني اقصد ان يكون كل صف لرمز منتسب ومعه اطفاله في نفس الصف وكما في الجدول المرفق في الشيت (بعد).

واتمنى ان اكون وضحت الفكرة للاعضاء الكرام ولكم مني فائق الاحترام واعتذر على ازعاجكم .مع التقدير 

اطفال.xlsx

[محمد هشام.]

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

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

على العموم اتمنى ان اكون قد استوعبت طلبك اخي الكريم 😁 اليك كودين ولك الاختيار

 هدا كود لنقل البيانات من الاعمدة الى الصفوف حسب الرمز المكرر  من شيت اطفال الى شيت اخر (DATA )

Sub Transpose_to_columns()
Dim inp_arr, i As Long, out_arr, dict As Object, key As String
Set dict = CreateObject("Scripting.Dictionary")
With Sheets("اطفال")
  inp_arr = .Range(.Cells(2, 5), .Cells(.Rows.Count, 1).End(xlUp)).Value
End With
For i = 1 To UBound(inp_arr)
  key = CStr(inp_arr(i, 1))
  If dict.Exists(key) Then
    dict(key) = dict(key) & ";" & inp_arr(i, 3) & ";" & inp_arr(i, 4) & ";" & inp_arr(i, 5)
  Else
    dict.Add key, inp_arr(i, 3) & ";" & inp_arr(i, 4) & ";" & inp_arr(i, 5)
  End If
Next i
ReDim out_arr(1 To dict.Count, 1 To 4)
For i = 0 To dict.Count - 1
  out_arr(i + 1, 1) = dict.Keys()(i)
  out_arr(i + 1, 2) = dict.Items()(i)
Next i
With Sheets("data")
  .Cells(2, 1).Resize(dict.Count, 2) = out_arr
  .Cells(2, 2).Resize(dict.Count, 1).TextToColumns Destination:=.Cells(2, 2), DataType:=xlDelimited, Semicolon:=True
End With
Set dict = Nothing
Sheets("data").Activate
End Sub

 وهدا كود لنقل البيانات من الاعمدة الى الصفوف حسب الرمز المكرر في نفس الشيت  (اطفال)

Sub MH_transpose_colmns()
Dim der, t, ref, nbr&, i&, i1&, i2&
Application.ScreenUpdating = False
With ActiveSheet
   If .FilterMode Then .ShowAllData
   der = Cells(Rows.Count, "a").End(xlUp).Row
   Columns("a:e").Resize(der).Sort key1:=Range("a1"), order1:=xlAscending, _
         key2:=Range("b1"), order2:=xlAscending, Header:=xlYes
   t = Columns("a:e").Resize(der + 1).Value2
   ReDim r(1 To 1, 1 To Columns.Count - Range("h1").Column - 1)
   Range(Range("h1"), Cells(Rows.Count, Columns.Count)).Clear
   ref = t(2, 1): i1 = 2: i2 = i1: nbr = 1: r(1, nbr) = ref
   Do
      If t(i2, 1) = ref Then
         nbr = nbr + 1: r(1, nbr) = t(i2, 3)
         nbr = nbr + 1: r(1, nbr) = t(i2, 4)
         nbr = nbr + 1: r(1, nbr) = t(i2, 5)
         i2 = i2 + 1
      Else
         Cells(Rows.Count, "h").End(xlUp).Offset(1).Resize(, nbr) = r
         ReDim r(1 To 1, 1 To Columns.Count - Range("h2").Column - 1)
         i1 = i2: i2 = i1: ref = t(i2, 1): nbr = 1: r(1, nbr) = ref
         If ref = "" Then Exit Do
      End If
   Loop
End With

    Application.ScreenUpdating = True
End Sub

واليك الملف مع اضافة الاكواد ....في حالة الرغبة في الاضافة او التعديل لا تتردد اخي الكريم.بالتوفيق ...

اطفال_MH.xlsm

[شبل ليث]

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

بقي شي واحد ظهر في خلايا (جنس الطفل) رقم طوبل والمفروض ان يكون (1) ويمثل ذكر او (2) ويمثل انثى وظهر في خلية (تولد الطفل) رقم 1 والمفروض ان يكون تاريخ ميلاد الطفل .

اتمنى منكم المساعدة وان شاء الله سيكون اخر طلب ازعجكم به .

ولكم فائق التقدير والاحترام

[محمد هشام.]

تفضل اخي المشكلة في تنسيق الخلايا ليس اكثر تم تعديل الملف 

اطفال_MH-3.xlsm

[شبل ليث]

شكرا جزيلا للمبدع الاستاذ Mohamed Hicham

هذا هو المطلوب بالضبط بارك الله بك وبهذا المنتدى الرائع وفقكم الله تعالى .