طلب ترحيل موظف

[yazan_2]

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

لدي موظفين في المؤسسة التي اعمل بها
كل مرتبة  صفحة خاصة بها وكل موظف معلومات  وارغب  عند ترقيته بتغيير رقم المرتبة  ينتقل الى  صفحة الخاصة بالمرتبة المرقى عليها
مثلا:
عمر موظف على المرتبة 6
وعند الترقية اقوم فقط بتغيير رقم الوظيف الحالية الى رقم7 ويتم نقله مباشرة الى صفحة المرتبة 7 ويتم وضعه في اخر تسلسل
ولو كانوا اكثر من واحد
يتم نقلهم مرتبين في صفحة المرتبة 7  حسب التسلسل الوظيفي

 

كما ارغب في وضع InputBox لاختيار المرتبة المراد النقل منها الى المرتبة المحدده
فمثلا ارغب في ان يكون هنالك رسالة InputBox احدد فيها صفحة المرتبة 6 الى المرتبة 12
ويقوم اكسل بالتحديث ومن وجده  من الموظفين في نطاق هذه الصفحات تم تغير مرتبته يقوم بنقله تلقائيا الى صفحة المرتبة المسجله 

= ارغب في المساعدة ولكم خالص التقديرترحيل موظف.xlsx

تم تعديل سبتمبر 2 بواسطه yazan_2

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

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

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

Sub نقل_الموظف_بالنقر_المزدوج(employeeName As String, fromRank As String, toRank As String)
    Dim wsFrom As Worksheet
    Dim wsTo As Worksheet
    Dim found As Range
    Dim lastRow As Long
    
    On Error Resume Next
    Set wsFrom = ThisWorkbook.Sheets("المرتبة " & fromRank)
    Set wsTo = ThisWorkbook.Sheets("المرتبة " & toRank)
    On Error GoTo 0
    
    If wsFrom Is Nothing Or wsTo Is Nothing Then
        MsgBox "المرتبة غير صحيحة.", vbExclamation
        Exit Sub
    End If
    
    Set found = wsFrom.Columns(3).Find(What:=employeeName, LookIn:=xlValues, LookAt:=xlWhole)
    
    If Not found Is Nothing Then
        lastRow = wsTo.Cells(wsTo.Rows.Count, 3).End(xlUp).Row + 1
        wsTo.Rows(lastRow).Value = wsFrom.Rows(found.Row).Value
        
        wsTo.Cells(lastRow, 4).Value = toRank
        
        wsFrom.Rows(found.Row).Delete
        MsgBox "تم نقل الموظف بنجاح.", vbInformation
    Else
        MsgBox "لم يتم العثور على الموظف.", vbExclamation
    End If
End Sub

ثم في كل صفحة اكتب الكود التالي

 

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim employeeName As String
    Dim fromRank As String
    Dim toRank As String
    
    If Target.Column = 3 And Target.Row >= 2 Then
        employeeName = Target.Value
        fromRank = Replace(Me.Name, "المرتبة ", "")
        
        toRank = InputBox("أدخل المرتبة المنقول إليها للموظف " & employeeName & ":")
        If toRank = "" Then Exit Sub
        
        Call نقل_الموظف_بالنقر_المزدوج(employeeName, fromRank, toRank)
        
        Cancel = True
    End If
End Sub

       

  ترحيل موظف1.xlsb   

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

[yazan_2]

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

تقبل عاطر التحية والتقدير

[yazan_2]

لا ازال في انتظار المحترفين !!
هل يمكن المساعدة

[yazan_2]

السلام عليكم ورحمة الله وبركاته
لا اعلم هل السؤال غير مفهوم
ام صعب تحقيقه ؟!!

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

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

 السؤال واضح ولكن وضع فكرة السؤال في كود تحتاج الى وقت لجعل العمل  بالملف بطريقة مبسطة وليست معقدة المهم  فكرة الكود الحالية بدون اي InputBox    ملفك به عدة صفحات كل صفحة بمرتبة معينة  

اذا اردت تغيير المراتب فمثلا في صفحة مرتبة 6 قم بتغييرعدد من الموظفين الى مراتب جديدة متساوية او مختلفة ثم اذهب الى صفحة مرتبة9 مثلا وقم بتغيير  مراتب موظفين الى مراتب اعلى او اقل 

عند الضغظ على الزر يتم حذف من تغييرت مراتبهم من صفحاتهم وترحليهم كل الى صفحته والكود يرحل من مرتبة اقل الى اعلى او العكس

بالمختصر خطوتان الاولى امام اي موظف غير المرتبة المطلوبة لاي عدد تشاءوفي اي صفحة 

الثانية الضغظ على الزر 

الكود

Sub TransferEmployeeData()
    Dim ws As Worksheet
    Dim targetWs As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim rank As String
    Dim targetRank As String
    Dim targetRow As Long
    Dim data As Variant
    Dim targetData As Variant
    Dim targetLastRow As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    For Each ws In ThisWorkbook.Worksheets
        If Left(ws.Name, 7) = "المرتبة" Then
            lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
            
            For i = lastRow To 2 Step -1
                rank = ws.Cells(i, 4).Value
                
                If rank <> Mid(ws.Name, 9) Then
                    On Error Resume Next
                    Set targetWs = ThisWorkbook.Worksheets("المرتبة " & rank)
                    On Error GoTo 0
                    
                    If Not targetWs Is Nothing Then
                        targetLastRow = targetWs.Cells(targetWs.Rows.Count, "A").End(xlUp).Row + 1
                        
                        targetWs.Rows(targetLastRow).Value = ws.Rows(i).Value
                        
                        ws.Rows(i).Delete
                    End If
                End If
            Next i
        End If
    Next ws
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

الملف

ترحيل موظف1 (1).xlsb

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

[yazan_2]

كل الشكر والتقدير اخي الكريم  عبدالله  ماقصرت  ربي يزيدك من فضله ونعيمة

هل ممكن تتكرم علي ان امكن بشرح عمل الكود
وفي حال زيادة عدد المراتب واضافة صفحات هل اقوم فقط بتفعيل الكود؟
وفي حال تم تغيير اسم الصفحة ؟

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

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

11 ساعات مضت, yazan_2 said:

وفي حال زيادة عدد المراتب واضافة صفحات هل اقوم فقط بتفعيل الكود؟

إذا كنت ترغب في زيادة عدد المراتب، لا تحتاج إلى تعديل الكود نفسه. الكود مصمم للتعامل مع أي عدد من أوراق العمل التي تبدأ بكلمة “المرتبة”.

11 ساعات مضت, yazan_2 said:

وفي حال تم تغيير اسم الصفحة ؟

الجملة الشرطية If Left(ws.Name, 7) = "المرتبة" Then تعني التحقق مما إذا كانت أول سبعة أحرف من اسم ورقة العمل (ws.Name) تساوي كلمة “المرتبة”.

شرح الجملة الشرطية بالتفصيل:

• Left(ws.Name, 7): هذه الدالة تأخذ أول سبعة أحرف من اسم ورقة العمل. على سبيل المثال، إذا كان اسم الورقة هو “المرتبة 1”، فإن Left(ws.Name, 7) ستعيد “المرتبة”.
• = “المرتبة”: هذه هي المقارنة التي تتحقق مما إذا كانت أول سبعة أحرف تساوي كلمة “المرتبة”.

إذا كانت هذه المقارنة صحيحة، فإن الكود داخل الجملة الشرطية سيتم تنفيذه. هذا يعني أن الكود سيعمل فقط على أوراق العمل التي تبدأ أسماؤها بكلمة “المرتبة”.

 

شرح الكود

1. تعطيل تحديث الشاشة والحساب التلقائي:

   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual

   يتم تعطيل تحديث الشاشة والحساب التلقائي لتحسين أداء الكود أثناء التنفيذ.

2. التكرار عبر جميع أوراق العمل:

   For Each ws In ThisWorkbook.Worksheets
       If Left(ws.Name, 7) = "المرتبة" Then

   يتم التكرار عبر جميع أوراق العمل في المصنف، ويتم التحقق من أن اسم الورقة يبدأ بكلمة “المرتبة”.

3. الحصول على آخر صف يحتوي على بيانات في العمود “A”:

   lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

4. التكرار عبر الصفوف من الأسفل إلى الأعلى:

   For i = lastRow To 2 Step -1
       rank = ws.Cells(i, 4).Value

   يتم التكرار عبر الصفوف من الأسفل إلى الأعلى للحصول على قيمة المرتبة من العمود “D”.

5. التحقق من أن المرتبة لا تتطابق مع اسم الورقة:

   If rank <> Mid(ws.Name, 9) Then
   

6. تحديد ورقة العمل المستهدفة بناءً على المرتبة:

   On Error Resume Next
   Set targetWs = ThisWorkbook.Worksheets("المرتبة " & rank)
   On Error GoTo 0
   

7. نقل الصف إلى ورقة العمل المستهدفة وحذف الصف من الورقة الأصلية:

   If Not targetWs Is Nothing Then
       targetLastRow = targetWs.Cells(targetWs.Rows.Count, "A").End(xlUp).Row + 1
       targetWs.Rows(targetLastRow).Value = ws.Rows(i).Value
       ws.Rows(i).Delete
   End If
   

8. إعادة تمكين تحديث الشاشة والحساب التلقائي:

   Application.ScreenUpdating = True
   Application.Calculation = xlCalculationAutomatic
   

[yazan_2]

يا اخي لك خالص الشكر والتقدير على ما قدمته وتقدمه
نفع الله بك وزادك من فضلة