السلام عليكم و رحمة الله وبركاته
اخي الفاضل
استفدنا من الكود الموجود
وقمنا بعمل كود يقوم بـ4خطوات بضغطة واحدة
ترحيل الفاتورة
طباعة الفاتورة بعد الترحيل
مسح الفاتورة
زيادة رقم 1 لرقم الفاتورة بعد المسح
Sub trhil_invoice()
Application.ScreenUpdating = False
Dim LR As Long, LR1 As Long
Dim WS As Worksheet
Dim WS1 As Worksheet
Set WS = Worksheets("INVOICE")
Set WS1 = Worksheets("mat")
LR1 = WS1.Range("c55555").End(xlUp).Row + 1
Dim FR
For r = 6 To LR1
If WS1.Cells(r, 3) = WS.Range("I3") Then MsgBox "This invoice already exist, No shift will done": Exit Sub
Next
For FR = 10 To 50
If WS.Cells(FR, 3) = "" Then GoTo 7
WS1.Cells(LR1, 2) = WS.Range("E3").Value
WS1.Cells(LR1, 3) = WS.Range("I3").Value
WS1.Cells(LR1, 4) = WS.Range("E5").Value
WS1.Cells(LR1, 12) = WS.Range("E7").Value
WS.Range("D" & FR & ":J" & FR).Copy
WS1.Range("E" & LR1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
LR1 = LR1 + 1
7 Next FR
Application.CutCopyMode = False
WS.Select
Application.ScreenUpdating = True
2 Range("A1:K53").PrintOut Copies:=1
Q1 = MsgBox("Êã ÍÝÙ ÈíÇäÇÊ ÇáÝÇÊæÑÉ æ ÌÇÑí ØÈÇÚÉ ÇáÝÇÊæÑÉ - åá ÊÑíÏ ØÈÇÚÉ äÓÎ ÇÎÑì", vbYesNo, "ØÈÇÚÉ")
If Q1 = vbYes Then GoTo 2
Range("E3,E5,E7,D10:H49,J10:J49").ClearContents
Range("E3").Select
ActiveWindow.SmallScroll Down:=-45
Range("I3") = Range("I3") + 1
End Sub
آمل ان يكون به المطلوب
نموزج فاتورة.rar