ارجو المساعده

[waleedsh3alan]

هل بمكن تفريغ الفاتوره فى جدول الاضافات فى كل مره عمل فاتوره

asd.rar

[سليم حاصبيا]

جرب هذا الماكرو

Option Explicit

Sub Transform_Array()
Dim First_Sh As Worksheet, Sec_Sh As Worksheet
Set First_Sh = Sheets("فاتوره"): Set Sec_Sh = Sheets("اضافه")
Dim t%, x%, i%

t = Application.CountIf(Sec_Sh.Range("b:b"), First_Sh.Range("D3"))
 If t <> 0 Then MsgBox "هذا الرقم (الاضافة) موجود الرجاء استبداله": Exit Sub
     With Sec_Sh
          x = Application.Max(First_Sh.Range("b8:b27"))
           i = .Cells(Rows.Count, "f").End(3).Row + 1
        '================================
         With .Range("b" & i)
            .Offset(, 0) = First_Sh.Range("d3")
            .Offset(, 1) = First_Sh.Range("d4")
            .Offset(, 2) = First_Sh.Range("d5")
            .Offset(, 3) = First_Sh.Range("g3")
            .Offset(1, 3).Resize(x, 6).Value = First_Sh.Range("c8").Resize(x, 6).Value
          End With
     End With
End Sub

الملف مرفق

 

asd salim.rar