saad abed

جرب الاتى
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

اخى
جرب المرفق لعله المطلوب
حذف محتوى خلاي في الصفوف.rar