ترحيل كل مرتبة وظيفية في ورقة مستقلة

[yazan_2]

السلام عليكم ورحمة الله وبركاته
طبتم وطابت اوقاتكم بالخير والمسرات
لدي بيانات موظفين عدة يصل الى ما يقارب 10 الف موظف وكل موظف له مرتبة  والجميع في ملف واحد 
وارغب في ترحيل كل مرتبة وظيفية في ورقة بنفس الاسم  دون حذف اي شي من الرئيسية

وايضا امكانية ان يتم ترحيل المراتب في ملف خارجي كل مرتبة في صفحة بنفس الملف 

والكل بنفس التنسيق والترتيب 
الطلب الثاني
اعطاء امكانية البحث باي معلومه للموظف مثل جوجل ويكون سريع لان العدد كبير  وايضح طريقة تكون الصفحة محمية ولكن البحث شغال

 

الموظفين.xlsx

[عبدالله بشير عبدالله]

وعليكم السلام ورحمة الله وبركاته

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

 

الموظفين.xlsb

تم تعديل سبتمبر 8 بواسطه عبدالله بشير عبدالله

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته

بعد ادن اخونا الفاضل @عبدالله بشير عبدالله واثراءا للموضوع 

1) تم تنفيد طلبك مع اظافة امكانية البحث على الملف عن طريق الإستعلام أو بالحروف الأولى عند تفعيل البحث التلقائي  CheckBox1

2) بالنسبة لإنشاء الأوراق على نفس الملف أو مصنف جديد تمت مراعات نسخ البيانات بنفس التنسيق والترتيب

3) تفعيل خاصية البحث مع  وجود حماية على ورقة الرئيسية  الباسوورد 1234 

أكواد البحث من خلال Textbox1

Public WS As Worksheet
Public Const WsPasse As String = "1234"
Sub Recherche() ' بحث بالإستعلام
    Dim OneRng As Range, c As Range
    Dim Clé As String, r As String, lastRow As Long
    
    Set WS = ThisWorkbook.Sheets("Main")
    WS.Unprotect Password:=WsPasse
    
    lastRow = WS.Columns("A:L").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    Clé = Trim(WS.Range("B1").Value)
    WS.OLEObjects("CheckBox1").Object.Value = False
    Application.ScreenUpdating = False
    Set OneRng = WS.Range("A3:L" & lastRow)
    OneRng.Interior.ColorIndex = xlNone
    If Clé = "" Then
        MsgBox "الرجاء إدخال قيمة البحث", vbExclamation
        Application.ScreenUpdating = True
        WS.Protect Password:=WsPasse
        Exit Sub
    End If
    Set c = OneRng.Find(What:=Clé, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
    If Not c Is Nothing Then
        r = c.Address
        Do
            c.Interior.Color = RGB(255, 0, 0)
            Set c = OneRng.FindNext(c)
        Loop While Not c Is Nothing And c.Address <> r
    Else
        MsgBox "لم يتم العثور على أي نتائج", vbInformation
    End If
    WS.Protect Password:=WsPasse
    Application.ScreenUpdating = True
End Sub
'==================================================
Sub Search_by_first_letters() 'بحث تلقائي
    Dim OneRng As Range
    Dim Clé As String, tmp As Variant
    Dim i&, j&, lastRow&, b As String
    
    Set WS = ThisWorkbook.Sheets("Main")

    WS.Unprotect Password:=WsPasse
    lastRow = WS.Columns("A:L").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    Set OneRng = WS.Range("A3:L" & lastRow)
    tmp = OneRng.Value
    Clé = Trim(WS.Range("B1").Value)
    OneRng.Interior.ColorIndex = xlNone
    
    If Clé = "" Then
        WS.Protect Password:=WsPasse
        Exit Sub
    End If
    Application.ScreenUpdating = False
    For i = 1 To UBound(tmp, 1)
        For j = 1 To UBound(tmp, 2)
            If Not IsEmpty(tmp(i, j)) Then
                b = Trim(CStr(tmp(i, j)))
                If Left(b, Len(Clé)) = Clé Then
                    WS.Cells(i + 2, j).Interior.Color = RGB(255, 0, 0)
                End If
            End If
        Next j
    Next i
    Application.ScreenUpdating = True
    WS.Protect Password:=WsPasse
End Sub

 

 

الموظفين.xlsb

[yazan_2]

5 ساعات مضت, محمد هشام. said:

وعليكم السلام ورحمة الله تعالى وبركاته

بعد ادن اخونا الفاضل @عبدالله بشير عبدالله واثراءا للموضوع 

1) تم تنفيد طلبك مع اظافة امكانية البحث على الملف عن طريق الإستعلام أو بالحروف الأولى عند تفعيل البحث التلقائي  CheckBox1

2) بالنسبة لإنشاء الأوراق على نفس الملف أو مصنف جديد تمت مراعات نسخ البيانات بنفس التنسيق والترتيب

3) تفعيل خاصية البحث مع  وجود حماية على ورقة الرئيسية  الباسوورد 1234 

أكواد البحث من خلال Textbox1

Public WS As Worksheet
Public Const WsPasse As String = "1234"
Sub Recherche() ' بحث بالإستعلام
    Dim OneRng As Range, c As Range
    Dim Clé As String, r As String, lastRow As Long
    
    Set WS = ThisWorkbook.Sheets("Main")
    WS.Unprotect Password:=WsPasse
    
    lastRow = WS.Columns("A:L").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    Clé = Trim(WS.Range("B1").Value)
    WS.OLEObjects("CheckBox1").Object.Value = False
    Application.ScreenUpdating = False
    Set OneRng = WS.Range("A3:L" & lastRow)
    OneRng.Interior.ColorIndex = xlNone
    If Clé = "" Then
        MsgBox "الرجاء إدخال قيمة البحث", vbExclamation
        Application.ScreenUpdating = True
        WS.Protect Password:=WsPasse
        Exit Sub
    End If
    Set c = OneRng.Find(What:=Clé, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
    If Not c Is Nothing Then
        r = c.Address
        Do
            c.Interior.Color = RGB(255, 0, 0)
            Set c = OneRng.FindNext(c)
        Loop While Not c Is Nothing And c.Address <> r
    Else
        MsgBox "لم يتم العثور على أي نتائج", vbInformation
    End If
    WS.Protect Password:=WsPasse
    Application.ScreenUpdating = True
End Sub
'==================================================
Sub Search_by_first_letters() 'بحث تلقائي
    Dim OneRng As Range
    Dim Clé As String, tmp As Variant
    Dim i&, j&, lastRow&, b As String
    
    Set WS = ThisWorkbook.Sheets("Main")

    WS.Unprotect Password:=WsPasse
    lastRow = WS.Columns("A:L").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    Set OneRng = WS.Range("A3:L" & lastRow)
    tmp = OneRng.Value
    Clé = Trim(WS.Range("B1").Value)
    OneRng.Interior.ColorIndex = xlNone
    
    If Clé = "" Then
        WS.Protect Password:=WsPasse
        Exit Sub
    End If
    Application.ScreenUpdating = False
    For i = 1 To UBound(tmp, 1)
        For j = 1 To UBound(tmp, 2)
            If Not IsEmpty(tmp(i, j)) Then
                b = Trim(CStr(tmp(i, j)))
                If Left(b, Len(Clé)) = Clé Then
                    WS.Cells(i + 2, j).Interior.Color = RGB(255, 0, 0)
                End If
            End If
        Next j
    Next i
    Application.ScreenUpdating = True
    WS.Protect Password:=WsPasse
End Sub

 

 

الموظفين.xlsb 43.81 kB · 4 downloads

التعديل متميز وخاصة بدخول ومشاركة هرمي الابداع والتميز الاخ عبدالله بشير ، والاح محمد هشام.
ومروركم شرف بحد ذاته .
وربما سهوت عن التنويه انه يمكن ان تكون المرتبة مثلا ( السابعه ) وقد تكون السابعه مهندسين والسابعه عادي بدون لقب ، وارغب في دمجهم في نفس الصفحة  السابعه والسبعه مهندسين ونفس مسماه في المرتبة ان امكن بدون حرج
فيما يخص البحث ارغب في ان يفرز  ويظهرون فقط من تنطبق عليهم شروط البحث / مثلا محمد
كل اسم فيه محمد يبدا او يحتوي 
 والبقيه لا تظهر  الا عند الرجوع عن البحث
وتحديد انطباق الشرط باللون هي لمسه ابداعيه منكم وارغب في ان تكون من بداية رقم البطاقة الى اخر سجل

تقبلوا خالص التحية والتقدير


 

[محمد هشام.]

منذ ساعه, yazan_2 said:

ربما سهوت عن التنويه انه يمكن ان تكون المرتبة مثلا ( السابعه ) وقد تكون السابعه مهندسين والسابعه عادي بدون لقب ، وارغب في دمجهم في نفس الصفحة  السابعه والسبعه مهندسين ونفس مسماه في المرتبة ان امكن بدون حرج

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

منذ ساعه, yazan_2 said:

فيما يخص البحث ارغب في ان يفرز  ويظهرون فقط من تنطبق عليهم شروط البحث / مثلا محمد
كل اسم فيه محمد يبدا او يحتوي 
 والبقيه لا تظهر  الا عند الرجوع عن البحث

اما بخصوص البحث اظن انك بحاجة لتغيير طريقة البحث  لتتمكن من فرز  البيانات بجزء من قيمة البحث على جميع الأعمدة  انصحك باستخدام نمودج مستخدم (يوزرفورم)  سيوفر لك سرعة جلب البيانات خاصة ان ملفك الاصلي يتضمن ما يقارب 10 الف موظف 

الموظفين 2.xlsb

تم تعديل سبتمبر 9 بواسطه محمد هشام.

[yazan_2]

اخي محمد هشام ابدعت. 
سال الله العظيم ان يبارك لك في علمك وان يرزقك من حيث لا تحتسب انت وكل من ساهم في وضع الحلول

فيما يخص اليوزر فورم .. فكره في بالي وان شاء الله ان وصلت لها لا استغني عن لمساتك الابداعية انت والاخوة الكرام

تقبل مني خالص الشكر والتقدير