ترحيل بيانات معقدة

[حسن البدوي]

اريد المساعدة في ترحيل بيانات الفاتورة علي الشكل الموجود في الشيت

ترحيل.xlsx

[حسونة حسين]

السلام عليكم ورحمه الله وبركاته وبها نبدأ

1- قم بوضع هذا الكود في موديل جديد

2- قم بحفظ الملف بصيغه تقبل الماكرو وليكن XLSB

3- ثم شغل الكود

Sub Tarhil()
    Dim WS As Worksheet, SH As Worksheet, AR1, AR2, I As Long, J As Long, LR1 As Long, LR2 As Long
    Set WS = ThisWorkbook.Sheets("فواتير العملاء")
    Set SH = ThisWorkbook.Sheets("فاتورة المبيعات")
    AR1 = Array("C3", "C4", "E4", "C5", "C6", "E3", "H3", "J4", "J6")
    AR2 = Array("B", "C", "D", "E", "F", "G", "H", "I", "J")
    LR1 = SH.ListObjects("الجدول4").Range.Columns(2).Cells.Find("*", SearchDirection:=xlPrevious).Row
    LR2 = WS.ListObjects("الجدول2").Range.Columns(1).Cells.Find("*", SearchDirection:=xlPrevious).Row + 1
    
    For I = 8 To LR1
        For J = 1 To 9
            WS.Cells(LR2, J).Value = SH.Range(AR1(J - 1)).Value
        Next J
        For J = 10 To 18
            WS.Cells(LR2, J).Value = SH.Cells(I, AR2(J - 10))
        Next J
        LR2 = LR2 + 1
    Next I

End Sub