اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


إذهب إلى أفضل إجابة Solved by سليم حاصبيا,

الردود الموصى بها

السلام عليكم

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

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

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

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

 

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

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

رابط هذا التعليق
شارك

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

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

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

فقط شيت   المصدر (  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

  • Like 2
رابط هذا التعليق
شارك

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

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

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

الف شكر لكم

 

 

 

 

 

  • Like 1
رابط هذا التعليق
شارك

  • أفضل إجابة

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

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

  • Like 1
رابط هذا التعليق
شارك

 

 

في ١١‏/٦‏/٢٠١٩ 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

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

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

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

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

هل هاذا ممكن 

 

الف شكر ليكم 

 

رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information