AmirMohamed

تمام وضحت الفكرة ، اليك المرفق بكود جديد وبه بعض التنسيقات ان شاء الله تعجبك
Private Sub CommandButton1_Click() Dim wsSource As Worksheet Dim wsDest As Worksheet Dim lastRow As Long Dim destRow As Long Dim dateFrom As Date Dim dateTo As Date Dim i As Long Dim headerRange As Range Dim tableRange As Range Set wsSource = ThisWorkbook.Sheets("ورقة1") Set wsDest = ThisWorkbook.Sheets("ورقة2") dateFrom = CDate(TextBox1.Value) dateTo = CDate(TextBox2.Value) lastRow = wsSource.Cells(wsSource.Rows.Count, "F").End(xlUp).Row destRow = 1 wsSource.Range(wsSource.Cells(1, 2), wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft)).Copy _ Destination:=wsDest.Cells(destRow, 2) wsDest.Cells(destRow, 1).Value = "م" wsDest.Cells(destRow, 1).Font.Bold = True wsDest.Cells(destRow, 1).Font.Size = 18 wsDest.Cells(destRow, 2).Resize(1, wsSource.Columns.Count - 1).Font.Bold = True wsDest.Cells(destRow, 2).Resize(1, wsSource.Columns.Count - 1).Font.Size = 18 destRow = destRow + 1 For i = 2 To lastRow If wsSource.Cells(i, 6).Value >= dateFrom And wsSource.Cells(i, 6).Value <= dateTo Then wsSource.Range(wsSource.Cells(i, 2), wsSource.Cells(i, wsSource.Columns.Count).End(xlToLeft)).Copy _ Destination:=wsDest.Cells(destRow, 2) wsDest.Cells(destRow, 1).Value = destRow - 1 wsDest.Cells(destRow, 1).Font.Size = 16 wsDest.Cells(destRow, 2).Resize(1, wsSource.Columns.Count - 1).Font.Size = 16 destRow = destRow + 1 End If Next i Set headerRange = wsDest.Range(wsDest.Cells(1, 1), wsDest.Cells(1, 7)) headerRange.Interior.Color = RGB(0, 102, 204) headerRange.Font.Color = RGB(255, 255, 255) wsDest.Columns("A").AutoFit wsDest.Columns("B").Resize(, wsSource.Columns.Count - 1).AutoFit Set tableRange = wsDest.Range(wsDest.Cells(1, 1), wsDest.Cells(destRow - 1, 7)) With tableRange.Borders .LineStyle = xlContinuous .Weight = xlThin .Color = RGB(173, 216, 230) End With MsgBox "تم فلترة البيانات بنجاح!" End Sub وفي كود الحذف بتضيف سطر كمان 
Private Sub CommandButton2_Click() On Error Resume Next sh2.Range("a1").CurrentRegion.Delete sh2.Range("a1").CurrentRegion.Clear End Sub اليك المرفق به التعديلات ♥
الدرس 259 (1).xlsm

اتمني اكون سددت المطلوب 
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

وعليكم السلام 
تفضل اخي الملف في المرفقات 
وهذي المعادلة المستخدمة :
=IF(C2<>"";TRANSPOSE(UNIQUE(FILTER(B:B; A:A = C2)));"")  
HHA.xlsx

Sub printpreview1() On Error GoTo ErrorHandler ThisWorkbook.Windows(1).Visible = True Application.Visible = True Dim lastRow As Long Dim ws As Worksheet ' تحديد ورقة العمل المطلوبة Set ws = ThisWorkbook.Sheets("sheet") ' العثور على آخر صف يحتوي على بيانات lastRow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row If lastRow > 0 Then ' إعداد منطقة الطباعة لتشمل كل الأعمدة With ws .PageSetup.PrintArea = .Cells(1, 1).Resize(lastRow, ws.Columns.Count).Address .PrintPreview End With End If Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbExclamation, "خطأ" End Sub تمام تفضل اخي الكريم

جرب هذا الكود اخي 
=IF(TODAY()>G3;INT((DATEDIF(G3; TODAY(); "m") / 4) * 10);"لم يأتي الموعد")  

تفضل اخي الكريم ♥
ورقة (1).xls
الورقة الاولى فقط اللي تدخل فيها البيانات والباقي بتلاقيه موجود مثل التقارير