ترتيب اسماء

[nany4mg]

السادة الافاضل

    بعد التحية "

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

1.xlsm

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

في المرة الفادنة

1- رفع ملف ضغير لا يتجاوز 50 صف لأن الماكرو الذي بعمل على صف واحد يمكنه العمل على الألوف منها

2-رفع ملف يحتوي على جدول كامل (كان هناك في الجدول بيانات ناقصة كثيرة وقد قمت بادراج بيانات عشوائيه )

3- يتم توزيع الموظفين على 3 صفخات مع الاسماء مرتبة ابجدياً (     Acounting /    JobList  /   Sale )

جرب هذا الماكرو

Option Explicit
Sub filter_and_sort()
Dim Sh2 As Worksheet
Dim My_sh As Worksheet
Dim Rg As Range
Dim cret$
    With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    End With
Set Sh2 = Sheets("sheet2")
Set Rg = Sh2.Range("A1").CurrentRegion
If Sh2.AutoFilterMode Then Rg.AutoFilter

For Each My_sh In Sheets
  Select Case True
      Case My_sh.Name = "Acounting"
        cret = "ادارة الحاسب"
      Case My_sh.Name = "JobList"
        cret = "ادارة شئون العاملين"
      Case My_sh.Name = "Sale"
        cret = "ادارة المبيعات"
      Case Else
        GoTo Next_sh
 End Select
My_sh.Range("A1").CurrentRegion.Clear

  Rg.AutoFilter 3, cret
  Rg.SpecialCells(12).Copy
    With My_sh.Range("A1")
      .PasteSpecial (8)
      .PasteSpecial (12)
     
    End With
    
  With My_sh.Range("A1").CurrentRegion
    .Sort Key1:=.Cells(1, 2), Header:=1
    .Borders.LineStyle = 1
    .InsertIndent 1
    .Font.Size = 14
    .Font.Bold = True
    .Rows(1).HorizontalAlignment = 3
  End With

Next_sh:
Next
If Sh2.AutoFilterMode Then Rg.AutoFilter
  With Application
  .ScreenUpdating = True
  .Calculation = xlCalculationAutomatic
  .CutCopyMode = False
  End With
Sh2.Select
End Sub

nany4mg.xlsm

[nany4mg]

السلام عليكم ورحمة الله استاذ سليم الله ينور على حضرتك انا راجعت الملف وتمام وقمت بتعديل بعض الاشياء ولكن عندي مشكلة محتاج معادلة تعمل الاتي اذا كان لايوجد بيانات بالمعادلات تصبح الخانة فارغة لانني سوف اقوم بكتابة اسماء جديدة وساعتها احتاج ان انسخ المعادلات على هذه الاسماء  بمعنى الملف اخره 46 صف وانا احتاج اكمل الى 1000 اسم وانا موضح لحضرتك في الملف

 فهل ينفع ادراج معادلة لتصبح الخانة التي يوجد بها معادلة في sheet2 فارغة وشكرا لسيادتك 

nany4mg.xlsm

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

قم باضافة ما تريد والماكرو يعرف عمله على أكمل وجه(الشرط الوحيد دون صفوف فارغة)

[nany4mg]

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

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

با صديقي

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

لذلك
1- أضف الاسماء التي تريد في sheet2  مع البيانات التي تخصها
2-اسجب المعادلات (في sheet2 ) كل واحدة من الصف الاول الى اخر صف فيه داتا (أو أكثر كما تريد)
4- نفّذ الماكرو

هذا مثال (مرفق الملف) عما أقصده (1100 اسم وهمي ) مع المعادلات في sheet2 فقط 

ملاحظة: تم التعديل على المعادلات بجيث لا تظهر الأخطاء ولا الأصفار (الق  نظرة عليها في sheet2)

انسخ الاسماء الحقيقية من ملفك مكان الاسماء الوهمية أو انسخ الكود الى ملفك بعد ادراج الصفحات اللازمة 
     بنفس الأسماء   (     Acounting /    JobList  /   Sale ) 

ولا تنس تسمية الشيت الأساسي بـــ sheet2

nany4mg_1100.xlsm

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

لا أعمل على جداول فارغة وليس من واجبي تعبئة بيانات ولو كانت عشوائية
كما فعلت سابقاً

تفضل املأ الجدول ببعض الاسماء والبيانات 20 اسم وليس 400)

[nany4mg]

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

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

ممكن ان تستعين بهذا الملف صفحة (Finish)

nany4mg_Final.xlsm

[yara ahmed]

ماشاء الله تبارك الله

حفظك الله سليم حاصبيا