محمد7788 قام بنشر يوليو 29, 2020 مشاركة قام بنشر يوليو 29, 2020 السلام عليكم ورحمة الله وبركاته ارجوا المساعدة فى الملف المرفق اعمدة بها بيانات المعلمين بالمعهد وكل يوم يطلب منى عمل احصاء متضمن هذه الاعمدة ولكم بترتيب مختلف وقد قمت بعمل قائمة منسدلة لكل عمود وانا اريد عند اختيار اسم العمود يتم نقل بيانات العمود بحيث اقوم بعمل تبديل بين الصفوف عن طريق القائمة النسدلة ولكم جزيل الشكر احصائيات المعهد.xlsx رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر يوليو 30, 2020 مشاركة قام بنشر يوليو 30, 2020 جرب هذا الملف 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 2 رابط هذا التعليق شارك More sharing options...
محمد7788 قام بنشر يوليو 30, 2020 الكاتب مشاركة قام بنشر يوليو 30, 2020 شكرا جدا استاذ سليم على سرعة التجاوب عندى طلب اخر بعد اذنك قمت بتنسق الخلايا فى ورقة العمل Mian وجعل الارقام عربية وكذلك فى ورقة العمل final ولكن عند الضغط على الزر "Run Please" يقوم بإرجاع التنسيق الى اللغة الانجليزية فهل بالامكان جلب البيانات بنفس تنسيق mian وكذلك تنسيق التاريخ وكذلك الغاء الوان الخلايا من اجل الطباعة ايضا عندما اقوم بعمل فلترة على ملف mian اريد ان يقوم بجلب البيانات المفلترة فقط اسف على الاطال رابط هذا التعليق شارك More sharing options...
أفضل إجابة سليم حاصبيا قام بنشر يوليو 30, 2020 أفضل إجابة مشاركة قام بنشر يوليو 30, 2020 كان من المفورض طرح هذه الأسئلة مسبقاً و دون تضييع الوقت تم تعديل الماكرو خسب ما تريد 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 1 1 رابط هذا التعليق شارك More sharing options...
محمد7788 قام بنشر يوليو 30, 2020 الكاتب مشاركة قام بنشر يوليو 30, 2020 استاذ سليم حضرتك انا حاولت انسخ الملف وكمان الكود على الملف الرئيسى لكن مازالت المشكلة قائمة حتى بعد التعديل اليك الملف الرئيسى صانع الاحصائيات (تم الحفظ تلقائياً).xlsm رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر يوليو 30, 2020 مشاركة قام بنشر يوليو 30, 2020 كيف تريد ان يعمل الكود ما دام لا يوجد تنسيق بين اسماء الشيات الفعلية واسماءها داخل الكود و حتى النطاق في الكود مختلف عما هو في الشيت الاساسي استبدل "Main" باسم الشبت الاساسي و "Final" باسم شيت الذي تريد نقل البيانات اليه واسم النطاق"A3:AN3" بنطاق العناوين في الشيت الاساسي 1 رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان