اذهب الي المحتوي
أوفيسنا

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


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

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

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

احصائيات المعهد.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

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

شكرا جدا استاذ سليم على سرعة التجاوب عندى طلب اخر بعد اذنك قمت بتنسق الخلايا فى ورقة العمل 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

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

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

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

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

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

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

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

 

Pic-1.png

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

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



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

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

Important Information