محتاج كود يسحب لي بيانات جدول من شيت الى شيت باخر حسب اسم الشخص

[t.alzubadi90]

السلام عليكم يعطيكم  العافية  

عندي جدولين الاول جدول الفواتير وبياناتها 

والثاني جدول ابيه حق اسم واحد يعني يطلع لي الفواتير اللي دفعها هالشخص 

يعني بمجرد ما احط اسم يطلعلي الفواتير اللي دفعها 

 

 

 

 

تم تعديل يوليو 27 بواسطه t.alzubadi90
اضافة صور الجداول

[محمد هشام.]

لايمكن الاشتغال على صورة المرجوا ارفاق ملفك مع عينة للنتائج المتوقعة 

[t.alzubadi90]

@محمد هشام.

 

السلام عليكم 

يسعد صباحك استاذ محمد 

المطلوب نقل المعلومات من  الشيت AA الى الشيت UU

حسب الاسم نسحب البيانات اللي

يعني مجرد ما نكتب اسم الدافع يطلع لنا المبالغ اللي دفعها ةالتفاصيل المطلوبة 

وتقبل تحياتي 

00.xlsm

[محمد هشام.]

اخي ما هو العمود المرغوب ترحيله الى رقم اليوزر

[محمد هشام.]

تفضل جرب هدا 

ملاحظة لم يتم تحديد العمود الاخير لعدم معرفتي لاسم العمود المرغوب جلب بياناته لهدا سبق تدكيرك بارفاق عينة للنتائج المتوقعة 

Sub Search_by_name()

    Dim WS As Worksheet, src As Worksheet
    Dim r As Variant, a As Variant, Rng As Range
    Dim i As Long, F As Long, Lastrow As Long
    Dim clé As Variant, Search As Range

Set WS = Worksheets("AA"): Set src = Worksheets("UU")
Lastrow = WS.Columns("B:I").Find(What:="*", _
    SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row

        Set Rng = WS.Range("B2:I" & WS.Cells(Rows.Count, "F").End(xlUp).Row)
        r = Rng.Value2: clé = src.[C1]
        
If clé = Empty Then: MsgBox "برجاء إدخال اسم للبحث عن بياناته", vbCritical, "الامل الدولية": Exit Sub

Set Search = WS.Range("F2:F" & Lastrow).Find(clé, LookIn:=xlValues, lookat:=xlWhole)
       If Search Is Nothing Then MsgBox clé & " غير موجود", vbExclamation: Exit Sub
    Application.ScreenUpdating = False
   src.Range("B3:G" & src.Rows.Count).ClearContents
        ReDim a(1 To UBound(r), 1 To UBound(r, 2))
   For i = 1 To UBound(r)
        If r(i, 5) = clé Then
            F = F + 1
            a(F, 1) = r(i, 2)
            a(F, 2) = r(i, 4)
            a(F, 3) = r(i, 6)
            a(F, 4) = r(i, 7)
            a(F, 5) = r(i, 3)
            ' رقم اليوزر
          '  a(F, ؟) = r(i, ؟)
        End If
     Next i
    src.[B2].Offset(1).Resize(F, UBound(a, 2)).Value2 = a
    Application.ScreenUpdating = True
End Sub

وفي حدث ورقة (UU)

Private Sub Worksheet_Activate()
' جلب الاسماء بدون تكرار
Set WS = Worksheets("AA")
Application.ScreenUpdating = False
Set MonDico = CreateObject("Scripting.Dictionary")
 For Each cnt In WS.Range("f2", WS.[f65000].End(xlUp))
   If cnt <> "" Then MonDico(cnt.Value) = ""
 Next cnt
  With WS.Range("L2:L65000")
   .ClearContents
   .Resize(MonDico.Count) = Application.Transpose(MonDico.Keys)
  End With
Application.ScreenUpdating = True
End Sub
'=====================
Private Sub Worksheet_Change(ByVal Target As Range)
' تنفيد الكود عند اختيار الاسم من القائمة المنسدلة
Select Case Target.Address(0, 0)
    Case "C1": Call Search_by_name
    Target.Select
    Case Else: Exit Sub
End Select
End Sub

الخلية C1 ورقة   (UU) ضع الصيغة التالية 

=OFFSET(AA!$L$2, 0, 0, COUNTA(AA!$L:$L), 1)

بالتوفيق.........

 

Search_by_name.xlsm

تم تعديل يوليو 28 بواسطه محمد هشام.

[t.alzubadi90]

شكرا استاذ محمد 

والسموحة على التاخير او عدم ايصال المعلومة 

رقم اليوزر = رقم المعرف

استاذي

ما ضبطت معي ممكن تنسقها لي 

بحيث في زر البحث 

يطلع النتائج مو نظام قائمة لان ممكن الاسماء تكون 70 اسم

وجزاك الله خير  

Search_by_name.xlsm

[محمد هشام.]

أظن أن نظام القائمة أسهل!!!!

هل تقصد أنك ترغب بكتابة الإسم وجلب البيانات باستخدام زر البحث؟

جرب هذا 

ReDim a(1 To UBound(r), 1 To UBound(r, 2))
   For I = 1 To UBound(r)
        If r(I, 5) = clé Then
            F = F + 1
            a(F, 1) = r(I, 2):a(F, 2) = r(I, 4): a(F, 3) = r(I, 6)
            a(F, 4) = r(I, 7):a(F, 5) = r(I, 3):a(F, 6) = r(I, 1) 
        End If
     Next I

 

Search_by_name-V2.xlsm

تم تعديل يوليو 30 بواسطه محمد هشام.

[t.alzubadi90]

استاذ محمد هشام

 

شكرا  لك   وبارك الله فيك على الافادة 🌼

 

@محمد هشام.