اريد كود للتعديل في اكثر من شيت لهذا البرنامج

[khaledm123]

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

اريد مساعدة حضراتكم في استكمال هذا المشروع وجزاكم الله خيرا 

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

برنامج مخازن الفرع كلمة المرورuserوالباسوورد 12345.rar

[أسامة البراوى]

السلام عليكم

مرفق الملف بعد إضافة الاكواد التالية مع توضيح أجزاء الكود وتفعيل عمليات البحث والاضافة والحفظ

* تم اضافة زرار مؤقت باللون الاصفر لاستدعاء الفورم من الشاشة الرئيسة

برنامج مخازن user 12345.zip

 

' تعريف المتغيرات الرئيسه
Dim Sheet_Name As String
Dim L_Row As Integer
Dim Current_Row As Integer


Private Sub UserForm_Initialize()
    ' ملء الكمبوبوكس الأساسى حسب جدول اسماء الشيتات
    L_Row = ThisWorkbook.Sheets("هام جدا للبرمجة").Range("A" & Rows.Count).End(xlUp).Row
    Me.ComboBox1.RowSource = "='هام جدا للبرمجة'!A2:A" & L_Row
End Sub

Private Sub ComboBox1_Change()
    ' عند اختيار اسم الشيت يتم حفظةفى المتغير الرئيسي لاستعماله فيما بعد
    Sheet_Name = Me.ComboBox1.Value
    L_Row = Sheets(Sheet_Name).Range("A" & Rows.Count).End(xlUp).Row
    
    ' ربط الشيت بالليست بوكس
    ListBox2.Visible = True
    Me.ListBox2.ColumnCount = 2
    Me.ListBox2.ColumnWidths = "70,120"
    ListBox2.RowSource = "='" & Sheet_Name & "'!A3:B" & L_Row

 End Sub

Private Sub ListBox2_Change()
    ' التنقل عبر اختيارالبنود من الليست بوكس
    Current_Row = ListBox2.ListIndex + 3
    Me.TextBox1 = Sheets(Sheet_Name).Range("A" & Current_Row)
    Me.TextBox2 = Sheets(Sheet_Name).Range("B" & ListBox2.ListIndex + 3)
End Sub

Private Sub CommandSearch_Click()
'   البحث عن قيم معينة وادراجها فى الليست بوكس الخاصة بالبحث
   ListBox1.Clear
    If Len(Sheet_Name) = 0 Then
        MsgBox "من فضلك اختار ورقة العمل"
        Exit Sub
    End If
   If Len(Trim(TextBox3.Text)) = 0 Then
        MsgBox "لم يتم إدخال قيمة للبحث عنها"
        ListBox1.Visible = False
        Exit Sub
    End If
    
    Dim myArray() As String
    Dim iRow As Integer
    ListBox1.ColumnCount = 3
    ListBox1.ColumnWidths = "0, 70,120"
     
    For i = 0 To ListBox2.ListCount - 1
    
        If InStr(1, ListBox2.List(i, 1), TextBox3.Text) <> 0 Then
            ListBox1.AddItem
' إضافة عمود مخفى برقم البند فى الليست يوكس الاساسي لتسهيل التنقل
            ListBox1.List(ListBox1.ListCount - 1, 0) = i
            ListBox1.List(ListBox1.ListCount - 1, 1) = ListBox2.List(i, 0)
            ListBox1.List(ListBox1.ListCount - 1, 2) = ListBox2.List(i, 1)
        End If
    Next
    ListBox1.Visible = True
  
End Sub

Private Sub ListBox1_Change()
  'كود التنقل بواسطة قائمة نتائج البحث
    If ListBox1.ListCount > 0 Then
        If ListBox1.ListIndex > -1 Then
            ListBox2.ListIndex = ListBox1.List(ListBox1.ListIndex, 0)
        
        End If
    End If
End Sub

Private Sub Command_Add_Click()
'  لإضافة بند جديد يتم إضافة سطر الى مصدر الليست الاساسى ثم التنقل الى السطر الجديد
    If Len(Sheet_Name) = 0 Then
        MsgBox "من فضلك اختار ورقة العمل"
        Exit Sub
    End If
     
    L_Row = L_Row + 1
   
    ListBox2.RowSource = "='" & Sheet_Name & "'!A3:B" & L_Row
    ListBox2.ListIndex = L_Row - 3
      
End Sub

Private Sub CommandDelete_Click()
  ' كود الحذف
     If Len(Sheet_Name) = 0 Then
        MsgBox "من فضلك اختار ورقة العمل"
        Exit Sub
    End If
    
    If Current_Row = 0 Then
        MsgBox "قم باختيار القيم التى تود حذفها"
        Exit Sub
    End If
   Dim R
   R = MsgBox("هل ترغب فى حذف السطر الحالى", vbOKCancel + vbCritical + vbMsgBoxRight + vbMsgBoxRtlReading, "تاكيد الحذف")
   If R = vbOK Then
         Sheets(Sheet_Name).Rows(Current_Row).Delete
   End If
   ComboBox1_Change
   
End Sub

Private Sub CommandSave_Click()
 ' كود الحفظ
    If Len(Sheet_Name) = 0 Then
        MsgBox "من فضلك اختار ورقة العمل"
        Exit Sub
    End If
    
    If Current_Row = 0 Then
        MsgBox "قم باختيار القيم التى تود تعديلها او حفظها مسبقا"
        Exit Sub
    End If
    If TextBox1.Text = "" Or TextBox2.Text = "" Then
        MsgBox "هناك خطأ فى بيانات الكود أو الاسم"
        Exit Sub
    End If
'يمكنك هنا ايضا إضافة جمل برمجيةالتأكد من عدم تكرار رقم الصنف اوالكود مسبقا
   
    
  
        If Application.WorksheetFunction.CountIf(Sheets(Sheet_Name).Range("A1:A" & L_Row), TextBox1.Text) > 0 Then
            If Sheets(Sheet_Name).Range("A" & Current_Row).Value = TextBox1.Text Then GoTo 1
                 MsgBox "الكود المدخل متكرر برجاء التأكد من عدم تكرار الاكواد", vbOK + vbCritical + vbMsgBoxRight + vbMsgBoxRtlReading, "الكود موجود مسبقا"
                TextBox1.Text = Sheets(Sheet_Name).Range("A" & Current_Row).Value
                Exit Sub
           
        End If
        
1:  Dim CodeNr
    Dim CodeDiscr
   
   ' يفضل حفظ البيانات بعد التحديث فى متغيرات مؤقتة لتفادى الخطأ اثناء الحفظ ثم تحديثها  فى ورقة العمل
    CodeNr = TextBox1.Text
    CodeDiscr = TextBox2.Text
 
   Sheets(Sheet_Name).Range("A" & Current_Row).Value = CodeNr
   Sheets(Sheet_Name).Range("B" & Current_Row).Value = CodeDiscr
     
    MsgBox "تم حفظ البيانات بنجاح", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading, "تاكيد"
End Sub
Private Sub CommandEnd_Click()
        
        Me.Hide
        UserFormMain.Show
        
End Sub

 

 

تم تعديل يناير 24, 2023 بواسطه أسامة البراوى

[khaledm123]

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

تم تعديل يناير 31, 2023 بواسطه khaledm123

[khaledm123]

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

تم تعديل يناير 31, 2023 بواسطه khaledm123