مساعدة فى تبديل الاعمدة عن طريق قائمة منسدلة

[محمد7788]

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

احصائيات المعهد.xlsx

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

جرب هذا الملف

1- تم تصحيح البيانات للقوائم المنسدلة 

2 تم تغيير اسماء الصفخات الى اللغة الاجنبية

3- تم وضع بيانات عشوائية لزيادة الصفوف (صفين لا يكفيان) في الشيت الاساسي "’Main"'

4- في الصفحة "Final" استبدل اسم العامود الى ما تريد(من القائمة المنسدلة في الصف الثالث)

5-  اضغط على الزر "Run Please"

Option Explicit

Sub From_one_to_two()
Dim M As Worksheet
Dim F As Worksheet
Dim LF%, col%, i%
Dim F_rg As Range, y%
Dim S_rg As Range
Dim max_ro%

Application.ScreenUpdating = False
Set M = Sheets("Main"): Set F = Sheets("Final")
Set S_rg = M.Range("A3:AM3")
col = F.Cells(3, Columns.Count).End(1).Column
F.Range("a5").Resize(5000, col).Clear
For i = 2 To col
 Set F_rg = S_rg.Find(F.Cells(3, i), lookat:=1)
  If F_rg Is Nothing Then GoTo Next_I
   y = F_rg.Column
   max_ro = M.Cells(Rows.Count, y).End(3).Row
   F.Cells(5, i).Resize(max_ro).Value = _
   M.Cells(4, y).Resize(max_ro).Value
Next_I:
Next

LF = F.Range("A5").CurrentRegion.Rows.Count
 F.Range("A5").Resize(LF) = _
Evaluate("Row(" & 1 & ":" & LF & ")")
 With F.Range("A5").Resize(LF, col).SpecialCells(2)
  If .Cells(1, 1) <> vbNullString Then
   .Borders.LineStyle = 1
   .InsertIndent 1
   .Font.Size = 14: .Font.Bold = True
   .Interior.ColorIndex = 19
  End If
 End With
 Application.ScreenUpdating = True
End Sub

الملف مرفق

 

Nhnd_7788.xlsm

[محمد7788]

شكرا جدا استاذ سليم على سرعة التجاوب عندى طلب اخر بعد اذنك قمت بتنسق الخلايا فى ورقة العمل Mian وجعل الارقام عربية وكذلك فى ورقة العمل final ولكن  عند الضغط على الزر "Run Please" يقوم بإرجاع التنسيق الى اللغة الانجليزية فهل بالامكان جلب البيانات بنفس تنسيق mian وكذلك تنسيق التاريخ وكذلك الغاء الوان الخلايا من اجل الطباعة  

ايضا عندما اقوم بعمل فلترة على ملف mian اريد ان يقوم بجلب البيانات المفلترة فقط 

اسف على الاطال

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

كان من المفورض طرح هذه الأسئلة مسبقاً و دون تضييع الوقت

تم تعديل الماكرو خسب ما تريد

Option Explicit

Sub From_one_to_two()
Dim M As Worksheet
Dim F As Worksheet
Dim LF%, col%, i%
Dim F_rg As Range, y%
Dim S_rg As Range
Dim max_ro%
Dim Flt_rg
Application.ScreenUpdating = False
Set M = Sheets("Main"): Set F = Sheets("Final")
Set S_rg = M.Range("A3:AM3")
col = F.Cells(3, Columns.Count).End(1).Column
F.Range("a5").Resize(5000, col).Clear
For i = 2 To col
 Set F_rg = S_rg.Find(F.Cells(3, i), lookat:=1)
  If F_rg Is Nothing Then GoTo Next_I
   y = F_rg.Column
   max_ro = M.Cells(Rows.Count, y).End(3).Row
   M.Cells(4, i).Resize(max_ro - 2).SpecialCells(12).Copy
   F.Cells(5, y).PasteSpecial (12)
Next_I:
Next

LF = F.Range("A5").CurrentRegion.Rows.Count
 F.Range("A5").Resize(LF) = _
 Evaluate("Row(" & 1 & ":" & LF & ")")
 F.Range("A5").Resize(LF).NumberFormat = "[$-,200] 0"
 With F.Range("A5").Resize(LF, col).SpecialCells(2)
  If .Cells(1, 1) <> vbNullString Then
   .Borders.LineStyle = 1
   .InsertIndent 1
   .Font.Size = 14: .Font.Bold = True
   End If
 End With
 F.PageSetup.PrintArea = F.Range("A3").Resize(LF + 2, col).Address

  Rem ++++++++++ Optional +++++++++++++++
        '  If M.FilterMode Then
        '   M.Range("a3").CurrentRegion.AutoFilter
        '  End If
  Rem ++++++++++ Optional +++++++++++++++
 Application.ScreenUpdating = True
End Sub

الملف من جديد

 

Mhnd_7788_with filter.xlsm

[محمد7788]

استاذ سليم  حضرتك انا حاولت انسخ الملف وكمان الكود على الملف الرئيسى لكن مازالت المشكلة قائمة حتى بعد التعديل اليك الملف الرئيسى

صانع الاحصائيات (تم الحفظ تلقائياً).xlsm

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

كيف تريد ان يعمل الكود  ما دام لا يوجد تنسيق بين اسماء الشيات الفعلية واسماءها داخل الكود

و حتى النطاق في الكود مختلف عما هو في الشيت الاساسي

استبدل "Main"  باسم الشبت الاساسي و "Final"  باسم شيت الذي تريد نقل البيانات اليه
 واسم النطاق"A3:AN3" بنطاق العناوين في  الشيت الاساسي