طريقة تحويل بيانات الجدول الى صف افقي واحد

[اياد م]

السلام عليكم

كل عام وانتم بخير

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

الجدول الاساسي في المرفق الاول

الجدول المطلوب الافقي في الجدول الثاني

 

شاكرين ومقدرين لكم

m جدول الطالب.xls الجدول افقي.xlsx

[عادل حنفي]

اخي 

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

ارجو التجربة في النلف المرفق

تحياتي

Copy of2 الجدول افقي.xlsm

[Ali Mohamed Ali]

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

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

بعد اذن الاستاذ عادل

هذا الكود ربما كان أسرع (يدون الكثير من الحلقات التكرارية)

تم تغيير اسناء الصفحات (تفادياً لظهور احرف غير مفهومة اثناء نسخه)

فقط شيت   المصدر (  Source)   وشيت الهدف  ( Target )

Option Explicit

Sub Get_Data()
Rem ======>>> Created By Salim Hasbaya On 10/6/2019
 Application.ScreenUpdating = False
 Dim DIC As New Dictionary
 Dim T As Worksheet: Set T = Sheets("Target")
 Dim s As Worksheet: Set s = Sheets("Source")
 Dim laste_ro%: laste_ro = Cells(Rows.Count, "b").End(3).Row
 Dim i%, stp%: stp = 5
 Dim K%, my_key
 
 T.Range("a2:p5000").ClearContents
 
 With s
  For K = 17 To laste_ro Step stp
    DIC.Add .Range("q" & K).Value, _
    .Range("B" & K).Resize(stp, 15).Value
   Next
 End With
  
  i = 2
   For Each my_key In DIC.Keys
    T.Range("a" & i) = my_key
    T.Range("b" & i).Resize(stp, 15) = DIC(my_key)
    i = i + stp + 1
   Next my_key
   
   DIC.RemoveAll
   Application.ScreenUpdating = True
End Sub

الملف مرفق

 

Data_with_dictinary.xlsm

[اياد م]

16 ساعات مضت, عادل حنفي said:

اخي 

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

ارجو التجربة في النلف المرفق

تحياتي

Copy of2 الجدول افقي.xlsm 749.06 \u0643\u064a\u0644\u0648 \u0628\u0627\u064a\u062a · 4 downloads

يعطيك العافية استاذ عادل الف شكر لك

 

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

 

لانه كل فترة اقوم بسحب ملف جديد من نظام المدرسة

 

الف شكر ليكم

9 ساعات مضت, سليم حاصبيا said:

بعد اذن الاستاذ عادل

هذا الكود ربما كان أسرع (يدون الكثير من الحلقات التكرارية)

تم تغيير اسناء الصفحات (تفادياً لظهور احرف غير مفهومة اثناء نسخه)

فقط شيت   المصدر (  Source)   وشيت الهدف  ( Target )

Option Explicit

Sub Get_Data()
Rem ======>>> Created By Salim Hasbaya On 10/6/2019
 Application.ScreenUpdating = False
 Dim DIC As New Dictionary
 Dim T As Worksheet: Set T = Sheets("Target")
 Dim s As Worksheet: Set s = Sheets("Source")
 Dim laste_ro%: laste_ro = Cells(Rows.Count, "b").End(3).Row
 Dim i%, stp%: stp = 5
 Dim K%, my_key
 
 T.Range("a2:p5000").ClearContents
 
 With s
  For K = 17 To laste_ro Step stp
    DIC.Add .Range("q" & K).Value, _
    .Range("B" & K).Resize(stp, 15).Value
   Next
 End With
  
  i = 2
   For Each my_key In DIC.Keys
    T.Range("a" & i) = my_key
    T.Range("b" & i).Resize(stp, 15) = DIC(my_key)
    i = i + stp + 1
   Next my_key
   
   DIC.RemoveAll
   Application.ScreenUpdating = True
End Sub

الملف مرفق

 

Data_with_dictinary.xlsm 647.51 \u0643\u064a\u0644\u0648 \u0628\u0627\u064a\u062a · 2 downloads

الف شكر استاذ سليم مجهودكم جبار

انا الي ابيه اسم مع بياناته طول الاسبوع في صف واحد بدون الغاء الدمج وبدون الغاء الاعمدة الزائدة

الف شكر لكم

 

 

 

 

 

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

ربما كان المطلوب

Option Explicit

Sub all_In_One_Row()
Application.ScreenUpdating = False
Dim M As Worksheet: Set M = Sheets("MY_SHEET")
Dim S As Worksheet: Set S = Sheets("Source")
Dim s_row%: s_row = S.Cells(Rows.Count, "P").End(3).Row
Dim I%, RGS As Range
Dim stp%: stp = 17
Dim x, k%: k = 3
Dim col%, n%: n = 3
Dim y%: y = 3
Dim RO%: RO = 17
Dim Colr%, New_R%
M.Range("b17").CurrentRegion.Clear
 For I = 17 To s_row Step 5
  Set RGS = S.Range("b" & I & ":P" & I + 4)
  x = RGS.Cells.Count
   M.Cells(stp, 2) = S.Range("Q" & I)
   stp = stp + 1
    For col = k To x + 15
     M.Cells(RO, y) = RGS.Cells(n)
      n = n + 1
      y = y + 1
   Next
   y = 3: RO = RO + 1: n = 3
  
  Next
  M.Columns("B:CL").EntireColumn.AutoFit
 New_R = M.Range("b17").CurrentRegion.Rows.Count
  For I = 15 To 90 Step 15
  M.Cells(17, I).Resize(26 - New_R).Interior.ColorIndex = 4
   Next
    M.Range("b17").CurrentRegion.Value = _
   M.Range("b17").CurrentRegion.Value
    
  Application.ScreenUpdating = True
End Sub

الملف مرفق صفحة  MY_SHEET

 

Data_with_dictinary_New.xlsm

[اياد م]

 

 

في ١١‏/٦‏/٢٠١٩ at 07:55, سليم حاصبيا said:

ربما كان المطلوب

Option Explicit

Sub all_In_One_Row()
Application.ScreenUpdating = False
Dim M As Worksheet: Set M = Sheets("MY_SHEET")
Dim S As Worksheet: Set S = Sheets("Source")
Dim s_row%: s_row = S.Cells(Rows.Count, "P").End(3).Row
Dim I%, RGS As Range
Dim stp%: stp = 17
Dim x, k%: k = 3
Dim col%, n%: n = 3
Dim y%: y = 3
Dim RO%: RO = 17
Dim Colr%, New_R%
M.Range("b17").CurrentRegion.Clear
 For I = 17 To s_row Step 5
  Set RGS = S.Range("b" & I & ":P" & I + 4)
  x = RGS.Cells.Count
   M.Cells(stp, 2) = S.Range("Q" & I)
   stp = stp + 1
    For col = k To x + 15
     M.Cells(RO, y) = RGS.Cells(n)
      n = n + 1
      y = y + 1
   Next
   y = 3: RO = RO + 1: n = 3
  
  Next
  M.Columns("B:CL").EntireColumn.AutoFit
 New_R = M.Range("b17").CurrentRegion.Rows.Count
  For I = 15 To 90 Step 15
  M.Cells(17, I).Resize(26 - New_R).Interior.ColorIndex = 4
   Next
    M.Range("b17").CurrentRegion.Value = _
   M.Range("b17").CurrentRegion.Value
    
  Application.ScreenUpdating = True
End Sub

الملف مرفق صفحة  MY_SHEET

 

Data_with_dictinary_New.xlsm 661.23 \u0643\u064a\u0644\u0648 \u0628\u0627\u064a\u062a · 6 downloads

يعطيك العافية استاذ 

انا الملف الاصلي لا *جدول الطالب *

لا ارغب في التعديل عليه من حذف الاعمدة الزائدة وازالة دمج الخلايا 

وفي الملف الجديد يظهر اسم الطالب وبجانبة جميع حصصة مرتبة بالايام 

هل هاذا ممكن 

 

الف شكر ليكم