طلب مساعدة في ربط خلاياء وانشاء شيت تلقائي

[ahs4500]

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

اعلم جيداً انني مقصر بحق هالمنتدى الجميل

وعند لا نجد حل او يصعب علينا شين لجاء لاخواني بمنتدى اوفيسنا

 

اخواني لدي ملف مرفق

1.      تم تصميم الواجة الرئيسية بشيت بإسم ( رئيسي ) لكي يتم اداخل المعلومات ويتم ترحيلها الى عدد كبير من الصفحات .

2.      تم عمل مثال على الرقم ( 1 ) عند الضغط على الرقم يتم التحويل الى صفحة المعلومات الخاصة بالموظف ( شيت 1 )

3.      تم عمل ربط للخلاياء من الشيت ( الرئيسي )

الحقيقة العمل متعب والربط متعب وخاصة اريد انشاء 500 شيت مرتبط بالشيت ( رئيسي ) مع ترحيل البيانات

سؤالي /

هل استطيع عند ادراج صف يتم ادراج شيت جديد مرتبط بالشيت الرئيسي

وكيف استطيع ترحيل البيانات من الشيت الرئيسي الى الشيت ( 1.2.3.....) بدون عمل ارتباط لان العملية يدوية متعبة جداً

والسلام عليكم.

احمد.xlsx

[محمد هشام.]

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

تفضل اخي .يتم انشاء شيت جديد تلقائيا عند الكتابة في عمود b  مع نسخ المعادلات للحصول على النتائج مباشرة في نفس الشيت المضاف

قم بنسخ هذا الكود في حدث شيت ("رئيسي")

 

Private Sub Worksheet_Activate()       'انشاء ارتباط تشعبي باسماء اوراق العمل
Dim ws As Worksheet
Application.ScreenUpdating = False
Worksheets("رئيسي").Range("b3:b500").ClearContents
Range("b3").Select
For Each ws In ActiveWorkbook.Worksheets
        If (ws.Name <> "رئيسي") Then
ActiveCell.Hyperlinks.Add Anchor:=ActiveCell, Address:="", SubAddress:="" & ws.Name & "!A1" & "", ScreenTip:="", TextToDisplay:=ws.Name
ActiveCell.Offset(1, 0).Select

Application.ScreenUpdating = True
End If
Next ws
Call MH
End Sub


'(b)انشاء ورقة جديدة تلقائيا واعادة تسميتها باخر قيمة موجودة في عمود

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Or Target.Row <= 2 Then Exit Sub
If Target.Column = 2 And Target.Value <> "" And Not (sheetExists(Target.Value)) Then
Call Bouton1_Cliquer
Sheets("رئيسي").Select

End If
End Sub

Function sheetExists(sheetToFind As String) As Boolean
sheetExists = False
For Each Sheet In Worksheets
   If sheetToFind = Sheet.Name Then
      sheetExists = True
       Exit Function
    End If
Next Sheet
End Function

 وهدا الكود في module

 

Public Sub MH()
'(b)'افراغ خلايا الجدول بشرط وجود فراغ في العمود
Dim a&
With Sheets("رئيسي")
    For a = .Cells(.Rows.Count, 3).End(xlUp).Row To 1 Step -1
        If .Cells(a, 2) = "" Then
            Range(Cells(a, 3), Cells(a, 13)).Select
            Selection.ClearContents
            .Cells(a + 1, 2).Select
        End If
    Next a
End With
End Sub


Sub Bouton1_Cliquer()
Dim lastLine As Integer
Dim NameSheet As String
Dim MH As Boolean
lastLine = ThisWorkbook.Sheets("رئيسي").Range("b" & Rows.Count).End(xlUp).Row
NameSheet = ThisWorkbook.Sheets("رئيسي").Range("b" & lastLine)

MH = feuilleExiste(NameSheet)
If MH = True Then
   
     MsgBox "يتعدر انشاء ورقة جديدة بسبب وجودها مسبقا ", vbInformation
Else
  
    Worksheets("1").Copy After:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = Worksheets("رئيسي").Cells(Rows.Count, 2).End(xlUp).Value
    Range("a1").Value = ActiveSheet.Name
    ThisWorkbook.Sheets("رئيسي").Activate
    
End If
End Sub

 

احمد_mh.xlsm

تم تعديل نوفمبر 12, 2022 بواسطه Mohamed Hicham

[ahs4500]

كل كلمات الشكر لا توفيك حقك

شكراً اخي محمد حقيقة يعجز اللسان عن الشكر الجزيل الذي يوفي حقك

انا فخور جداً بمنتدانا العملاق وتواجد الخبرات التي لا يعجزون عن شي

رفع الله قدر الجميع وزادكم الله من علمة وفضلة

شكراً شكراً شكراً

[ahs4500]

استاذ محمد

هل ممكن افعل حماية الورقة بالشيت 1.2.3 وهكذا

شوف رسالة الخطاء مرفقة

[محمد هشام.]

نعم اخي يمكنك دالك بالغاء تفعيل الحماية للخلية A1 في شيت رقم 1 لانها تتضمن اسم ورقة العمل وبها يتم جلب البيانات من شيت رئيسي وبعد حماية الشيت سوف يتم  تفعيل الحماية للشيتات الاخرى تلقائيا بعدانشاء الاوراق الجديدة   2 و 3..4......... لان الشيت يتم نسخه كما هو  مع تغيير الاسم فقط  

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

تم تعديل نوفمبر 12, 2022 بواسطه Mohamed Hicham

[ahs4500]

استاذي لقد تم حماية شيت رقم 1 وتطبقت الحماية على اي شيت يتم انشئة بواسطة عدم حماية الخلية A1

لو تكرمت استاذي هل استطيع حماية الملف الرئيسي كالاتي :

1. حماية الفتح برقم سري

2. حماية الصف رقم 2 لكي لا يتم حذف العناوين 

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

اعلم استاذي ان طلباتي كثيرة واخجل من حضرتك ولاكن لا املك غير الدعاء لك بظهر الغيب ومت بكل ود

سوف ارفق ملف بعد تعديلي 

‏‏احمد_mh - نسخة.xlsm

[محمد هشام.]

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

الطلب الاول :

تمت اضافة شاشة دخول  حيث يتم فتح البرنامج بادخال اسم المستخدم وكلمة المرور وعند ثلاث محاولات خاطئة يتم اغلاق البرنامج 

 اسم المسخدم  :admin

باسوورد :   1234

Private Sub cmdLogin_Click()

    Dim user As String
    
    Dim password As String
    
    user = Me.txtUserID.Value
    
    password = Me.txtPassword.Value
        
       'يمكنك نغيير بيانات الدخول من هتا
    
    If (user = "admin" And password = "1234") Or (user = "user" And password = "user") Then

    
        Unload Me
        Application.Visible = True
        
    Else
    
        If LoginInstance < 3 Then
     
            MsgBox "كلمة المرور غير صحيحة!!! حاول مرة اخرى", vbOKOnly + vbCritical, "بيانات الدخول غير صالحة"
            LoginInstance = LoginInstance + 1
            
        Else
        
            MsgBox "لقد تجاوزت الحد الأقصى لعدد محاولات تسجيل الدخول. سيتم اغلاق البرنامج", vbOKOnly + vbCritical, "!!!!!!!تنبيه "
            Unload Me
            ThisWorkbook.Close Savechanges:=False
            Application.Visible = True
            LoginInstance = 0
            
        End If
    
    End If
    
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

    If CloseMode = 0 Then Cancel = True

End Sub
    

 

الطلب الثاني : حماية الصف الثاني لكي لا يتم حدف العناوين 

ضع هدا الكود في حدث شيت رئيسي سيتم تثبيث العناوين حتى ولو تعمدت حدفها 

 

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Range("B2").Value = "إسم الملف"
Range("C2").Value = "المنطقة"
Range("D2").Value = "المدينة"
Range("E2").Value = "الحي"
Range("F2").Value = "رقم المنزل"
Range("G2").Value = "رقم رئيسي"
Range("H2").Value = "المرتبة"
Range("I2").Value = "الرتبة"
Range("J2").Value = "الإسم"
Range("K2").Value = "مسمى الوظيفة"
Range("L2").Value = "التخصص"
Range("M2").Value = "رقم الدورة"
Range("N2").Value = "رقم الجوال"

End Sub

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

قد تم اضافة باسوورد للملف لحماية الاوراق من الحدف يتم تفعيله تلقائيا عند الدخول للبرنامج  وعند الرغبة في التعديل .

Click Review > Protect Workbook.

وادخال كلمة المرور 1234 

Private Sub Workbook_Open()

    LoginInstance = 0
    Application.Visible = False
    frmLogin.Show
    
Feuil1.Select
ActiveWorkbook.Protect password:="1234", Structure:=True, Windows:=True

End Sub

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

'(b)انشاء ورقة جديدة واعادة تسميتها باخر قيمة موجودة في عمود

Sub MH2()
Dim lastLine As Integer
Dim NameSheet As String
Dim MH As Boolean
lastLine = ThisWorkbook.Sheets("رئيسي").Range("b" & Rows.Count).End(xlUp).Row
NameSheet = ThisWorkbook.Sheets("رئيسي").Range("b" & lastLine)

MH = feuilleExiste(NameSheet)
If MH = True Then
   
     MsgBox "يتعدر انشاء ورقة جديدة بسبب وجودها مسبقا ", vbInformation
Else

'في حالة تغيير كلمة المرور غلى الملف يجب تغييرها هنا في الكود
 
 'الغاء حماية الملف قبل تنفيد الكود
    ActiveWorkbook.Unprotect password:="1234"
   
    Worksheets("1").Copy After:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = Worksheets("رئيسي").Cells(Rows.Count, 2).End(xlUp).Value
    Range("A1").Value = ActiveSheet.Name
    ThisWorkbook.Sheets("رئيسي").Activate
    
    'اعادة تفعيل حماية الملف
    ActiveWorkbook.Protect password:="1234", Structure:=True, Windows:=True
End If

End Sub

بالتوفيق ....

 

__احمد_mh - نسخة 2.xlsm

[ahs4500]

عمل جبار استاذ محمد 

ولاكن عند تشغيل على اكسيل 2019 ظهرت بعض الرسائل لم افهمها 

سوف ارفق صورة للمشكلة

واعتذر منك كثيراً لقد اتعبتعك معي

 

[محمد هشام.]

اخي الملف يشتغل عندي بدون مشاكل مع العلم اني اشتغل على نسخة اوفيس 2021   جرب الان او احد الاخوة يقوم بالتجربة ويوافينا بالنتيجة.

اليك الملف بعد التعديل

__احمد_mh - نسخة 3.xlsm

[ahs4500]

اللسان يعجز عن الشكر استاذ محمد شكراً بحجم السماء

 

[محمد هشام.]

العفو اخي الكريم واي اضافة اخرى لا تتردد في طلبها

يكفي الظغط على زر افضل اجابة تفاديا لاهدار وقت الاساتدة في الاشتغال على الملف مرة اخرى

[حسونة حسين]

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

المشكله ليست في الملف المشكله في لغه الجهاز 

حل مشكله اللغه العربيه