الرجاء المساعدة فى اصلاح كود الاضافة والحذف

[محمد 2024]

السلام عليكم

تحية طيبة وكريمة إلى أساتذة المنتدى الكرام

فضلا وليس أمرا المساعدة فى إصلاح الأخطاء الموجودة بهذا الملف

1-      عند اضافة بيانات موظف جديد تتم الاضافة فى الصف السادس وليس كما هو موجود وعند اضافة موظف أخر تتم الاضافة فى نفس المكان بالصف السادس . أرجو من الأخوة الكرام توضيح الخطأ واصلاحه مع العلم يوجد كود للترتيب بعد الاضافة فهل هذا الكود سليم أم به أخطاء ؟

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

وعذرا أخوتى

Book11111.xlsb

تم تعديل سبتمبر 15, 2023 بواسطه محمد 2024

[محمد هشام.]

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

تفضل اخي 

Dim tbl As Worksheet: Set tbl = Sheet26
 If Me.TextBox1 = Empty Then: Exit Sub
 With tbl
    ligne = .Cells(.Rows.Count, "c").End(xlUp).Row + 1
End With
'لمنع التكرار التحقق من الاسم والكود
If Application.WorksheetFunction.CountIf(tbl.Range("c6:c" & ligne - 1), Me.TextBox1.Value) > 0 Then
 MsgBox "هذا الاســــــم مضاف مسبقا", vbCritical
 Exit Sub

End If
If Application.WorksheetFunction.CountIf(tbl.Range("B6:B" & ligne - 1), Me.TextBox3.Value) > 0 Then
 MsgBox "هذا الكــــــود مضاف مسبقا", vbCritical
 Exit Sub
End If

Dim msg As VbMsgBoxResult
msg = MsgBox("ترحيل البيانات ؟ ", vbYesNo + vbQuestion + vbDefaultButton2, "تعليمات")
Application.ScreenUpdating = False
    If msg = vbNo Then
    Exit Sub
Else
' ترحيل البيانات
tbl.Cells(ligne, 2) = Me.TextBox3.Value
tbl.Cells(ligne, 4) = Me.TextBox2.Text
tbl.Cells(ligne, 3) = Me.TextBox1.Text
tbl.Cells(ligne, 7) = Me.ComboBox1.Text
tbl.Cells(ligne, 8) = Me.ComboBox2.Text
tbl.Cells(ligne, 9) = Me.ComboBox3.Text
tbl.Cells(ligne, 10) = Me.TextBox4.Text
tbl.Cells(ligne, 11) = Me.ComboBox4.Text
tbl.Cells(ligne, 12) = Me.ComboBox5.Text
tbl.Cells(ligne, 15) = Me.ComboBox9.Text
tbl.Cells(ligne, 16) = Me.TextBox13.Text
tbl.Cells(ligne, 19) = Me.ComboBox7.Text
tbl.Cells(ligne, 26) = Me.ComboBox6.Text
tbl.Cells(ligne, 13) = Format(TextBox5.Value, "yyyy/mm/dd")
tbl.Cells(ligne, 14) = Format(TextBox6.Value, "yyyy/mm/dd")
tbl.Cells(ligne, 20) = Me.ComboBox8.Text
tbl.Cells(ligne, 22) = Me.TextBox10.Text
tbl.Cells(ligne, 23) = Me.TextBox11.Text
tbl.Cells(ligne, 24) = Me.TextBox12.Text
tbl.Cells(ligne, 21) = Me.TextBox14.Text
tbl.Cells(ligne, 25) = Me.TextBox7.Text
tbl.Cells(ligne, 17) = Me.TextBox8.Value
tbl.Cells(ligne, 18) = Me.TextBox9.Text
 
If Range("C7") <> "" Then  ' ترتيب
    tbl.Range("b6:Z" & ligne - 1).Sort Key1:=tbl.Range("C6"), Order1:=xlAscending, Header:=xlYes, DataOption1:=xlSortTextAsNumbers
    End If

tbl.Range("a6") = 1   ' ترقيم الجدول
tbl.Range("a6:a" & tbl.Range("c" & Rows.Count).End(xlUp).Row).DataSeries , xlDataSeriesLinear

' اظافة المعادلات
With tbl.Range("E6:E" & tbl.Range("A" & Rows.Count).End(3).Row)
    .Formula = "=IFERROR(DATE(LEFT(D6,1)+17&MID(D6,2,2),MID(D6,4,2),MID(D6,6,2)),"""")"
   ' .Value = .Value
  End With
  With tbl.Range("F6:F" & tbl.Range("A" & Rows.Count).End(3).Row)
    .Formula = "=IFERROR(VLOOKUP(MID(D6,8,2)*1,$AW$10:$AX$43,2,FALSE),"""")"
   ' .Value = .Value
  End With
  ' حدف الصفوف الفارغة  من الجدول
Call delete_les_lignes_vides
' افراغ
B_sup_Click
End If

Dim msg As VbMsgBoxResult   ' حدف
msg = MsgBox("حدف البيانات ؟ ", vbYesNo + vbQuestion + vbDefaultButton2, "تعليمات")
Application.ScreenUpdating = False
    If msg = vbNo Then
    Exit Sub
Else

   findValue = f.Cells(N_Row, 3)
    With f.ListObjects("Tableau1").DataBodyRange
        lr = .Cells(.Rows.Count, 1).Row
        For I = lr To 1 Step -1
            If .Cells(I, 3) = findValue Then
                .Rows(I).Delete
f.Range("a6") = 1
f.Range("a6:a" & f.Range("c" & Rows.Count).End(xlUp).Row).DataSeries , xlDataSeriesLinear
UserForm_Initialize
 End If
        Next I
    End With
    End If

 

Book V2.xlsb

[محمد 2024]

اخى الكريم محمد هشام شكرا لك و بارك الله فيك

سأقوم بالتجربة وأعذرنى أخى إن احتجت إلى مشورتك فتقبلها منا