عند الضغط على اسم العميل من القائمة يعطينا نتيجة الاستعلام ؟؟

[nourkim]

السلام عليكم 

لنفرض اني افحص من حين لآخر قاعد بيانات العملاء او الزبائن التي لدي و قد تكون في صفحة اخرى منفردة 

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

كما ان ملف الكسيل مرفق بالاسفل 

 

استعلام من خلال الضغط على اسم العميل.xlsx

 

[وجيه شرف الدين]

اتفضل اخى الكريم الملف لعله يفى بالغرض

نسخة من استعلام من خلال الضغط على اسم العميل.xlsm

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

3 ساعات مضت, وجيه شرف الدين said:

اتفضل اخى الكريم الملف لعله يفى بالغرض

نسخة من استعلام من خلال الضغط على اسم العميل.xlsm 20.97 \u0643\u064a\u0644\u0648 \u0628\u0627\u064a\u062a · 4 downloads

كود رائع استاذ مصطفى 

لكن يمكن تخفيف  الحلقات التكرارية 6 مرات  في كل صف (بازالة الحلقة التكرارية j ) التي لا لزوم لها

بذلك ننقل البيانات صفاً بعد صف  وليس خلية بعد اخرى في كل عامود (تخيل عندنا 500 عامود الحلقة اللازمة لــ j من 1 الى 500)

Private Sub Worksheet_Change(ByVal Target As Range)
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
If Target.Address = "$B$4" Then
    ورقة2.Range("A7:F55") = ""
    k = 7
    LR = Sheets(1).Range("C" & Rows.Count).End(xlUp).Row
    For i = 24 To LR
        If ورقة2.Range("B4") = ورقة1.Range("c" & i) Then
             ورقة2.Cells(k, 1).Resize(, 6).Value = _
             ورقة1.Cells(i, 4).Resize(, 6).Value
             k = k + 1
        End If
    Next
End If
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

 

[nourkim]

5 ساعات مضت, وجيه شرف الدين said:

اتفضل اخى الكريم الملف لعله يفى بالغرض

نسخة من استعلام من خلال الضغط على اسم العميل.xlsm 20.97 \u0643\u064a\u0644\u0648 \u0628\u0627\u064a\u062a · 5 downloads

شكرا لك استاذ على المشاركة ...  للاسف لم يظهر معي الماكرو .. مع ان الماكرو مفعل معي على اوفيس 2019 
ملاحظة : كنت طلبت من هل توجد طريقة انه عند الضغط على اي إسم من القائمة العادية  و ليس من قائمة منسدلة تظهر لي استعلام الزبون مباشرة .. 

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

تم معالجة الامر (بواسطة Auto filter )

مع تعبئة اوتوماتيكية للــ Combo Box دون تكرار

 

Copy_filtred_rows_without_Hedears.xlsm

[وجيه شرف الدين]

19 ساعات مضت, سليم حاصبيا said:

كود رائع استاذ مصطفى 

لكن يمكن تخفيف  الحلقات التكرارية 6 مرات  في كل صف (بازالة الحلقة التكرارية j ) التي لا لزوم لها

بذلك ننقل البيانات صفاً بعد صف  وليس خلية بعد اخرى في كل عامود (تخيل عندنا 500 عامود الحلقة اللازمة لــ j من 1 الى 500)

Private Sub Worksheet_Change(ByVal Target As Range)
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
If Target.Address = "$B$4" Then
    ورقة2.Range("A7:F55") = ""
    k = 7
    LR = Sheets(1).Range("C" & Rows.Count).End(xlUp).Row
    For i = 24 To LR
        If ورقة2.Range("B4") = ورقة1.Range("c" & i) Then
             ورقة2.Cells(k, 1).Resize(, 6).Value = _
             ورقة1.Cells(i, 4).Resize(, 6).Value
             k = k + 1
        End If
    Next
End If
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

 

استاذى واخى الحبيب استاذ سليم جزاكم الله خير الجزاء وحشتنى توجهتكم واراءكم البناءه شكرا استاذى الكريم

[edkawy]

جزاك الله خير يا استاذ / سليم على مجهودك

ملف سريع جدا و اكتر من ممتاز و انا بحاول اعدل على الكود عشان استخدمه على الملف بتاعى و ياريت لو ممكن حضرتك تساعدنى و تقوللى  :

1 - ازاى اقدر ازود عدد الاعمده فى الجدول الرئيسى وتظهر فى نفس الوقت فى صفحه الاستعلام ؟

2- ازاى الفورمات بتاعت صفحه الاستعلام تكون متغيره بتغير نتيجه البحث ؟

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

[kanory]

في ١‏/٧‏/٢٠١٩ at 21:40, سليم حاصبيا said:

كود رائع استاذ مصطفى 

لكن يمكن تخفيف  الحلقات التكرارية 6 مرات  في كل صف (بازالة الحلقة التكرارية j ) التي لا لزوم لها

بذلك ننقل البيانات صفاً بعد صف  وليس خلية بعد اخرى في كل عامود (تخيل عندنا 500 عامود الحلقة اللازمة لــ j من 1 الى 500)

Private Sub Worksheet_Change(ByVal Target As Range)
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
If Target.Address = "$B$4" Then
    ورقة2.Range("A7:F55") = ""
    k = 7
    LR = Sheets(1).Range("C" & Rows.Count).End(xlUp).Row
    For i = 24 To LR
        If ورقة2.Range("B4") = ورقة1.Range("c" & i) Then
             ورقة2.Cells(k, 1).Resize(, 6).Value = _
             ورقة1.Cells(i, 4).Resize(, 6).Value
             k = k + 1
        End If
    Next
End If
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

 

ما شاء الله تبارك الله .... كود جميل ..