سحب معلومات معيّنة من سطور من ورقة لأخرى

[Jasmin]

السلام عليكم اخوتي الكرام،

استكمالا لهذا الموضوع

وبعد التعديل، أرفق لكم الملف المرجو المساعدة في التعديل لسحب المعلومات ,وٍكتب المطلوب مجدداً

تحتوي ورقة المعاملات Transaction على العناصر المباعة مع الوصف وسعر الوحدة (تم إنشاؤها تلقائيًا باستخدام vlookup) description and unit price، ولا توجد مشكلة في هذه الورقة كما أن المعلومات مأخوذة من ورقة Items2023
الآن بالنسبة للورقة Receipt - أود كتابة رقم للإيصال يدويًا: Receipt nb (رقم الفاتورة - الموجود في ورقة المعاملة) واسترداد المعلومات كما هو مكتوب (الوصف + الكمية - السعر1 Price LBP والسعر 2 Price USD ) - 
المطلوب هو جلب كلّ المعلومات المتعلقة لهذا الرقم (كل السطور) من ورقة الTransaction  إلى Receipt وشكرا   .

(مُرفق مثال للايصال رقم 2) ..شكرا لكم جميعا.

Invoices-j3_03-officena.xlsm

[عبدالفتاح في بي اكسيل]

عذرا اخت  ياسمين  حقيقة  لم اقتنع   بتخطيط  البيانات  للورقة  ارى  انها   ليست  لائقة  .

كما  ان  مشاركتك  السابقة  بالمخزون  كانت  محيرة تكررين  نفس  كميات  المخزون لذلك  تركت  المجال  لغيري  لعله  يفهم بياناتك 

يحبذ  تنظيم  البيانات في  المرة  القادمة .

لقد  قمت  بتنظيمها  بعض  الشيء   كما انه  يوجد  لديك  خلايا  مدمجة  يجب  الغاؤها  حتى  لا يتسبب مشاكل  في  الاكواد .

اذا كنت  مصرة على  نفس  التخطيط  لبياناتك  حينها  اترك  المجال  لغيري  ليقوم  ما  يلزم  لضيق  وقتي . 

Sub test()
    Dim findStr As String
    Dim i As Long, r As Long
    Dim sh1 As Worksheet, sh2 As Worksheet, Arr()
    Set sh1 = ThisWorkbook.Worksheets("Transaction")
    Set sh2 = ThisWorkbook.Worksheets("Receipt")
    With sh1
        Arr = .Range(.Cells(2, 1), .Cells(LastRow(sh1), 11)).Value
    End With
       findStr = InputBox("Please Enter Receipt NO", "Receipt NO")
    sh2.Range("A7").CurrentRegion.ClearContents
        Application.ScreenUpdating = False
    With sh2
        .Range("A6:D6").Value =Array("Date", "Description", "QTY", "Price USD", "Price LBP")
                For i = LBound(Arr) To UBound(Arr)
                     If Arr(i, 11) = findStr Then
                r = LastRow(sh2) + 1
                .Cells(r, 1) = Arr(i, 1)
                .Cells(r, 2) = Arr(i, 3)
                .Cells(r, 3) = Arr(i, 8)
                .Cells(r, 4) = Arr(i, 4)
                .Cells(r, 5) = Arr(i, 5)
                .Cells(4, 2).Value = findStr
            End If
        Next
    End With
    Application.ScreenUpdating = True
End Sub
Function LastRow(ByVal ws As Worksheet, Optional ByVal col As Variant = 1) As Long
    With ws
        LastRow = .Cells(.Rows.Count, col).End(xlUp).Row
    End With
End Function

Invoices-j3_03-officena.xlsm

[Jasmin]

ألف شكر لكم..