اضافة الى الكود بعض التنسيقات

[صباح2024]

السلام عليكم

ممكن اضافة الى الكود بعض الاوامر لعمل تنسيقات للجدول

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

عمل تنسيقات بعد الضغط على الزر.xlsm

تم تعديل أكتوبر 3 بواسطه صباح2024

[AmirMohamed]

اتمني اكون سددت المطلوب 

Sub DeleteRows()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("ورقة1")

    Dim response As VbMsgBoxResult
    response = MsgBox("هل أنت متأكد أنك تريد نقل البيانات وحذفها من الجدول الأساسي؟", vbYesNo + vbQuestion, "تنبيه")
    If response = vbNo Then
        Exit Sub
    End If

    Dim lastRow As Long
    Dim lastRow1 As Long
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    lastRow1 = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row
    
    ws.Range("F3:J" & lastRow1).Clear
    ws.Range("A2:D" & lastRow).Copy
    ws.Range("G2").PasteSpecial Paste:=xlPasteAll
    ws.Range("A3:D" & lastRow).Clear
    ws.Range("F1:J1").Merge
    ws.Range("F1").Value = ws.Cells(1, 1).Value
    ws.Range("F1").NumberFormat = "dddd dd - mm - yyyy"

    With ws.Range("F1")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Font.Size = 18
        .Font.Bold = True
        .Interior.Color = RGB(217, 217, 217)
    End With

    With ws.Range("F2:J2")
        .Interior.Color = RGB(217, 217, 217)
        .Font.Size = 16
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With

    With ws.Range("G3:J" & lastRow)
        .Font.Size = 16
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With

    ws.Cells(2, "F").Value = "ت"
    Dim i As Long
    For i = 3 To lastRow
        ws.Cells(i, "F").Value = i - 2
    Next i

    ws.Range("F2:F" & lastRow).Borders.LineStyle = xlContinuous
    ws.Range("F2:F" & lastRow).HorizontalAlignment = xlCenter
    ws.Range("F2:F" & lastRow).VerticalAlignment = xlCenter

    ws.Columns("F").ColumnWidth = 6
    ws.Columns("G").ColumnWidth = 16.88
    ws.Columns("H").ColumnWidth = 19.68
    ws.Columns("I").ColumnWidth = 19.38
    ws.Columns("J").ColumnWidth = 8.5

    Application.CutCopyMode = False
    ws.Cells(1, 1).Value = ws.Cells(1, 1).Value + 1

End Sub

 

عمل تنسيقات بعد الضغط على الزر.xlsm

[صباح2024]

جزيت خير

تمام

تسلم