saad abed's post in تفريغ الفاتورة من البيانات بعد عملية الترحيل لأكثر من شيت was marked as the answer
جرب الاتى
Sub SaveBill()
On Error Resume Next
Dim Lrow As Integer
Lrow = ورقة3.Cells(ورقة3.Rows.Count, "a").End(xlUp).Offset(1, 0).Row
ورقة3.Cells(Lrow, "A") = sheet1.Cells(2, "B")
ورقة3.Cells(Lrow, "B") = sheet1.Cells(3, "B")
ورقة3.Cells(Lrow, "C") = sheet1.Cells(4, "B")
ورقة3.Cells(Lrow, "D") = sheet1.Cells(29, "D")
ورقة3.Cells(Lrow, "E") = sheet1.Cells(29, "F")
ورقة3.Cells(Lrow, "F") = sheet1.Cells(30, "F")
ورقة3.Cells(Lrow, "G") = sheet1.Cells(31, "F")
ورقة3.Cells(Lrow, "H") = sheet1.Cells(32, "F")
ورقة3.Cells(Lrow, "I") = sheet1.Cells(33, "F")
Dim LastRow As Integer
Dim R As Integer
''''''''''''''''''''''''''''''''
For R = 7 To 27
If (sheet1.Cells(R, "b") <> "") Then
LastRow = ورقة2.Cells(ورقة2.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
ورقة2.Cells(LastRow, "A") = sheet1.Cells(2, "B")
ورقة2.Cells(LastRow, "B") = sheet1.Cells(3, "B")
ورقة2.Cells(LastRow, "C") = sheet1.Cells(4, "B")
ورقة2.Cells(LastRow, "D") = sheet1.Cells(R, "B")
ورقة2.Cells(LastRow, "E") = sheet1.Cells(R, "C")
ورقة2.Cells(LastRow, "F") = sheet1.Cells(R, "D")
ورقة2.Cells(LastRow, "G") = sheet1.Cells(R, "E")
ورقة2.Cells(LastRow, "H") = sheet1.Cells(R, "F")
End If
Next
''''''''''''''''''''''''''''''''''''''''
sheet1.Range("b2").ClearContents
sheet1.Range("b3").ClearContents
sheet1.Range("b4").ClearContents
sheet1.Range("b7:e27").ClearContents
End Sub
غيرت اسم الورقة من ورقه1 الى sheet1
