ترحيل بيانات وإنشاء فاتورة

[أبو عبد الله _]

السلام عليكم 

أعضاء المنتدى الكرام بحثت فى المنتدى قبل عرض الموضوع لكن لم أتمكن من الوصول لما أريد 

المطلوب ترحيل بيانات اعتمادا على خلايا متفرقة والتوضيح داخل الملف المرفق

المعرض الخيري.xlsx

[أبو عبد الله _]

إذا تعذر العمل على البيانات بشكل أفقي يمكن التعا مل معها بشكل رأسي ( أعمدة )

مع ملاحظة : انه يتم ادخال جميع الارقام  ثم الترحيل

المعرض الخيري رأسي.xlsx

[أبو عبد الله _]

اذا كان الامر غير ممكن . هل يمكن تعديل المعادلة التالية والخاصة بالترحيل وأنا سوف أقوم بتوظيفها إن شاء الله 

=IF(COUNTIF(الطـلاب!$B$4:$B$1504;"اضافة")<ROWS(A$2:A2);"";INDEX(الطـلاب!$E$4:$E$1504;100000-SUMPRODUCT(LARGE((الطـلاب!$B$4:$B$1504="اضافة")*(100000-ROW(الطـلاب!$B$4:$B$1504));ROWS(A$2:A2)))-3))

هنا كما هو واضح يتم تحيل البيانات إذا وجدت كلمة إضافة في العمود B ..  أرغب في أن يتم الترحيل إذا كانت قيمة الخلايا في العمود B لا تساوي صفر  أو غير فارغة 

[lionheart]

Sub Test()
    Dim ws As Worksheet, sh As Worksheet, lr As Long, lc As Long, r As Long, c As Long, m As Long
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets(1)
        Set sh = ThisWorkbook.Worksheets(2)
        sh.Range("B7:C100").ClearContents
        lr = LastRow(ws)
        lc = LastCol(ws)
        m = 7
        For r = 4 To lr Step 2
            For c = 1 To lc
                If ws.Cells(r + 1, c).Value <> "" Then
                    sh.Cells(m, 2).Value = ws.Cells(r, c).Value
                    sh.Cells(m, 3).Value = ws.Cells(r + 1, c).Value
                    m = m + 1
                End If
            Next c
        Next r
    Application.ScreenUpdating = True
    MsgBox "Done", 64
End Sub

Function LastRow(sh As Worksheet)
    On Error Resume Next
        LastRow = sh.Cells.Find(What:="*", After:=sh.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
    On Error GoTo 0
End Function

Function LastCol(sh As Worksheet)
    On Error Resume Next
        LastCol = sh.Cells.Find(What:="*", After:=sh.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
    On Error GoTo 0
End Function

 

[أبو عبد الله _]

شكرا الاستاذ ( قبل الأسد ) تسلم يمينك هذا المطلوب بالفعل 

أرغب في اضافة بسيطة منكم

1- أن يتم العمل على الملف الرأسي لانني قمت بالتجهيز بالشكل الرأسي الموضح فى المرفق في المشاركة الثانية

2- أنه في حالة الضغط على ترحيل مرة ثانية ينقل البيانات تحت أخر صف يحتوى على بيانات