اضافة فقرة في الكود (عمل ترقيم بعد عملية الضغط على الزر)

[نبا زيد]

السلام عليكم

ممكن اضافة الى الكود عمل ترقيم بعد الضغط على زر التصفية 

وكما موضح بالملف

 

 

كود حذف وتنسيق وادراج.xlsm

تم تعديل نوفمبر 15, 2024 بواسطه نبا زيد

[نبا زيد]

السلام عليكم

 

[أبومروان]

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

ارجو ان يكون المطلوب

كود الترقيم 

Sub NumberRows()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    
 
    Set ws = ThisWorkbook.Sheets("ورقة1")
    
 
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    
    
    For i = 2 To lastRow
        ws.Cells(i, "A").Value = i - 1
    Next i
End Sub

كود التصفيه بعد التعديل 

Sub DeleteRows()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim deleteCount As Long
    Dim response As VbMsgBoxResult
    
    Set ws = ThisWorkbook.Sheets("ورقة1")
    
    ' تحديث العمود الذي يتم حساب آخر صف فيه من A إلى B
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    deleteCount = 0
   
    response = MsgBox("هل أنت متأكد أنك تريد حذف  من استلمو الاول والثاني", vbYesNo + vbQuestion, "تأكيد الحذف")
    
    If response = vbYes Then
        ' بدأ من الصف الأخير حتى الصف 3 كما في الكود الأصلي
        For i = lastRow To 3 Step -1
            ' العمل على العمود B و C للتحقق من وجود القيم قبل حذف الصف
            If ws.Cells(i, 2).Value <> "" And ws.Cells(i, 3).Value <> "" Then
                ws.Rows(i).Delete
                deleteCount = deleteCount + 1
             End If
        Next i
        MsgBox deleteCount & " صفوف تم حذفها.", vbInformation, "عملية الحذف"
    Else
        MsgBox "تم إلغاء عملية الحذف.", vbInformation, "إلغاء"
    End If


    ' تنسيق النصوص في النطاق B1:D50 بدلاً من A1:D50
    With ws.Range("B1:D50").Font ' تغيير النطاق ليشمل العمود B بدلاً من A
        .Name = "Arial"
        .Size = 16
        .Bold = True
        .Color = RGB(0, 0, 251) ' الأزرق
    End With

    ' إعداد الهوامش للطباعة
    With ActiveSheet.PageSetup
        .TopMargin = Application.InchesToPoints(0.5)
        .BottomMargin = Application.InchesToPoints(0.5)
        .LeftMargin = Application.InchesToPoints(0.5)
        .RightMargin = Application.InchesToPoints(0.5)
    End With

    ' كتابة التاريخ في العمود B (تم تحديثه من العمود A)
    ws.Range("B1").Value = Date - 1
    ws.Range("B1").NumberFormat = "dd/mm/yyyy"
    
    ' إزاحة التاريخ اليومي لكتابة اليوم في العمود A
    ws.Range("A1").Value = Format(Date - 1, "dddd")
NumberRows
End Sub

 

كود حذف وتنسيق وادراج (1).xlsm

[نبا زيد]

السلام عليكم

اشكرك - جزيت خير 

اني كنت محتاج كود لعمل ترقيم بعد عملية الحذف ( حاليا الكود يقوم بحذف عمود الاسماء ويحل مكانها ترقيم ) ليس هذا هو اللي احتاجه

الكود اللي محتاجه للترقيم ( ادراج عمود للترقيم ودفع الاعمدة الموجودة لليسار 

ارجو ان وصلت النتيجة المطلوبة

 

مثال.xlsm

[محمد هشام.]

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

 ممكن توضح لنا ما المانع من إظافة عمود التسلسل يدويا وإعادة تعديل الكود بما يتناسب مع شكل البيانات  ؟

اذا كان هذا يناسبك إليك الكود المعدل 

Sub DeleteRows()
    Dim WS As Worksheet, lastRow As Long, i As Long, OnRng As Range, response As VbMsgBoxResult

    Set WS = Sheets("ورقة1")
    lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row
    response = MsgBox("هل أنت متأكد أنك تريد حذف من استلمو الاول والثاني ؟", vbYesNo + vbQuestion, "تأكيد الحذف")

    If response = vbYes Then
        For i = lastRow To 3 Step -1
            If WS.Cells(i, 3).Value <> "" And WS.Cells(i, 4).Value <> "" Then
                If OnRng Is Nothing Then
                    Set OnRng = WS.Rows(i)
                Else
                    Set OnRng = Union(OnRng, WS.Rows(i))
                End If
            End If
        Next i

        If Not OnRng Is Nothing Then
            OnRng.Delete
            MsgBox OnRng.Count & " تم حذف الصفوف بنجاح", vbInformation, "عملية الحذف"
        Else
            MsgBox "لا توجد صفوف مطابقة للحذف", vbExclamation, "لم يتم الحذف"
        End If
    Else
        MsgBox "تم إلغاء عملية الحذف", vbInformation, "إلغاء"
        Exit Sub
    End If

        With WS.Range("A1:E50").Font
            .Name = "Arial": .Size = 16: .Bold = True: .Color = RGB(0, 0, 251)
        End With
        
        For i = 3 To WS.Cells(WS.Rows.Count, "B").End(xlUp).Row
            WS.Cells(i, 1).Value = i - 2
        Next i
        
        With WS.PageSetup
            .TopMargin = .BottomMargin = .LeftMargin = .RightMargin = Application.InchesToPoints(0.5)
        End With

    WS.[C1].Value = Date - 1: WS.[C1].NumberFormat = "dd/mm/yyyy"
    WS.[B1].Value = Format(Date - 1, "dddd")
    Application.ScreenUpdating = True
End Sub

 

مثال1.xlsm

[نبا زيد]

السلام عليكم - 

يتم الحذف بعدها تظهر 

هذه الرسالة

[محمد هشام.]

جرب هدا

Sub DeleteRows()
    Dim WS As Worksheet, lastRow As Long, i As Long, OnRng As Range
    Dim choose As VbMsgBoxResult, DataRng As Range, Cnt As Boolean
    Set WS = Sheets("ورقة1")
    Set DataRng = WS.Range("A1:E50")
    lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row
    
    Cnt = False
    For i = 3 To lastRow
        If WS.Cells(i, 3).Value <> "" And WS.Cells(i, 4).Value <> "" Then
            Cnt = True
            Exit For
        End If
    Next i

    If Not Cnt Then
        MsgBox "لا توجد بيانات مطابقة للحذف", vbExclamation, "خطأ"
        Exit Sub
    End If

    choose = MsgBox("هل أنت متأكد أنك تريد حذف من استلمو الاول والثاني ؟", vbYesNo + vbQuestion, "تأكيد الحذف")
    
    Application.ScreenUpdating = False
    If choose = vbYes Then
        For i = lastRow To 3 Step -1
            If WS.Cells(i, 3).Value <> "" And WS.Cells(i, 4).Value <> "" Then
                If OnRng Is Nothing Then Set OnRng = WS.Rows(i) Else Set OnRng = Union(OnRng, WS.Rows(i))
            End If
        Next i
        If Not OnRng Is Nothing Then
            OnRng.Delete
            For i = 3 To WS.Cells(WS.Rows.Count, "B").End(xlUp).Row
                WS.Cells(i, 1).Value = i - 2
            Next i
            MsgBox "تم حذف الصفوف بنجاح", vbInformation, "الحذف"
            
    With WS
        .PageSetup.TopMargin = .PageSetup.BottomMargin = .PageSetup.LeftMargin = .PageSetup.RightMargin = Application.InchesToPoints(0.5)
        .[C1].Value = Format(Date - 1, "dd/mm/yyyy")
        .[B1].Value = Format(Date - 1, "dddd")
    End With

            With DataRng.Font
                .Name = "Arial": .Size = 16: .Bold = True: .Color = RGB(0, 0, 251)
            End With

        Else
            MsgBox "لا توجد صفوف مطابقة للحذف", vbExclamation, "لم يتم الحذف"
        End If
    Else
        MsgBox "تم إلغاء عملية الحذف", vbInformation, "إلغاء"
    End If

    Application.ScreenUpdating = True
End Sub

 

مثال1 v2.xlsm

[نبا زيد]

جزيت خيرا

تسلموا