الرجاء مساعدتي في ترحيل البيانات

[asam1122]

الاخوه الافاضل جزاكم الله خير على المساعده

مرفق لكم ملف يحتوي على صفحتين او شيتين 

الصفحه الاولى تحتوي على رقم البند و اسم البند و تاريخ الصلاحية للبند

الصفحة الثانية هي التي اريد العمل عليها

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

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

ما اريد عمله هو التالي

1- عند كتابه رقم البند في الصفحه الثانيه في الفراغ الموضوع بجانب رقم البند ان يظهر لي كافة البنود 

التي بنفس رقم البند في الصفحه الرئيسيه مرتبه بتاريخ الصلاحيه بالاحدث اولا .

اتمنى اني وضحت المطلوب ولكم مني كل الشكر مقدما 

Microsoft Office Excel Worksheet جديد ‫‬.rar

[طارق محمود]

السلام عليكم

 

تفضل المرفق

Microsoft Office Excel Worksheet جديد2.rar

[جمال عبد السميع]

أخى الحبيب وبعد إذن أستاذى( طارق محمود )

وزيادة فى إثراء الموضوع هذا حل أخر بالمعادلات

microsoft Office.rar

[asam1122]

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

فعلا مبدعين

اشكركم من كل قلبي

شكرا لك اخي جمال عبد السميع وشكرا لك اخي طارق محمود

ولكن اذا سمح وقتك اخي محمود اريد منك اضافة بعض الشرح على الكود 

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$B$1" Then Exit Sub
Application.ScreenUpdating = False
    s = [B1]
    With Sheet1
        .Range("$A$1:$C$999").AutoFilter Field:=1, Criteria1:=s
        LR = .[A9999].End(xlUp).Row
        .Range("A1:C" & LR).Copy [E2]
        Application.CutCopyMode = False
         .Range("$A$1:$C$999").AutoFilter
     End With
     
    [B2] = [F3]:     [A7:C999].ClearContents
    
    LR = [E9999].End(xlUp).Row
    With Range("E3:G" & LR)
        .Sort Key1:=[G3], Order1:=xlAscending
        .Copy [A7]
    End With
    
    [E2:G999].ClearContents
Application.ScreenUpdating = True
End Sub

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

وشكرا مقدما

[عبدالله المجرب]

السلام عليكم 

بعد إذن الاستاذ طارق 

هذا شرح للكود

If Target.Address <> "$B$1" Then Exit Sub

شرط اذا لم يكن عنوان الخلية النشطة B1 يتم الخروج من الاجراء

====================================

Application.ScreenUpdating = False

إيقاف اهتزاز الشاشة

===================================

s = [B1]

المتغير S  يساوي قيمة الخلية B1 والتي تمثل رقم البند

==================================

 With Sheet1

تقدر تقول (مع الورقة الاولى)  ويتم التعامل مع هذه الورقة دون الذهاب اليها 

==================================

.Range("$A$1:$C$999").AutoFilter Field:=1, Criteria1:=s

تصفية تلقائية للمدى Range("$A$1:$C$999") في العمود الأول وبشرط المتغير S (طبعاً التصفية للمدى في الورقة الأولى)

====================================================

LR = .[A9999].End(xlUp).Row

متغير يساوي رقم الصف الأخير الذي به بيانات بعد التصفية

===================================================

.Range("A1:C" & LR).Copy [E2]

نسخ المدى A1:C ورقم أخر صف به بيانات في الورقة الأولى ولصقه في الخلية E2 من الورقة الثانية

==============================================

Application.CutCopyMode = False

الغاء وضع الصق والنسخ

==============================================

   .Range("$A$1:$C$999").AutoFilter
     End With

إنهاء وضع التصفية التلقائية في الورقة الأولى واغلاق التعامل مع هذه الورقة

===========================================

[B2] = [F3]:     [A7:C999].ClearContents

قينة الخلية B2 تساوي الخلية F3 ويتم مسح البيانات من المدى [A7:C999]

============================================

LR = [E9999].End(xlUp).Row

متغير لتحديد رقم أخر صف به بيانات في العمود E  من الورقة الثانية

===========================================

With Range("E3:G" & LR)
        .Sort Key1:=[G3], Order1:=xlAscending
        .Copy [A7]
    End With

في المدى E3:G وأخر صف يتم فرزه حسب العمود G تنازلياً 

نسخ البيانات في هذا المدى ولصقها في الخلية A7

انها التعامل مع هذا المدى

==========================================

[E2:G999].ClearContents
Application.ScreenUpdating = True

مسح البيانات في المدى E2:G999 (وهو المدى الذي تم لصق البيانات فيه) 

تفعيل اهتزلز الشاشة

============================================

ان شاء الله أكون وفقت في الشرح

[عبدالله المجرب]

ولاثراء الموضوع هذا كود مختصر 

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cl As Range
If Not Intersect(Target, [B1]) Is Nothing Then
[A7:C999].ClearContents
For Each Cl In Sheets("الرئيسيه").Range("A2:A" & Sheets("الرئيسيه").[A10000].End(xlUp).Row)
If Cl = Target Then Cl.Resize(1, 3).Copy Range("A" & [A10000].End(xlUp).Row + 1)
Next
End If
End Sub

[طارق محمود]

السلام عليكم

أخي الحبيب / أبامحمود (جمال عبد السميع)

ملك المعادلات (مع أني لم أشاهد بعد) أن حلك رائع كما تعودنا

جزاك الله خيرا ووفقك دائما لما يحب ويرضي

 

أخي العظيم / أباأحمد (عبدالله المجرب)

ماشاء الله

وفقت تماما في الشرح

لم أكن لأشرح الكود مثلما فعلت

 

والكود الأخير (مع أني لم أفحصه) أفضل بالتأكيد

جزاك الله خيرا ووفقك دائما لما يحب ويرضي

[جمال عبد السميع]

أستاذى ومهندس منتدانا العظيم ( طارق محمود ) شرف كبير من حضرتك هذه الثقة الكبيرة فيه وإن كنت أتمنى أن أكون نقطة فى بحر علمك لأن حضرتك من أساتذتى الذى أفخر بهم وأعتز

بارك الله فيك أستاذى وأكثر الله من أمثالك لأن حضرتك مثل يحتذى فى العلم والخلق والتواضع

[asam1122]

شكرا لكم من اعماق قلبي على مابذلتموه معي من مجهود

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

شكرا جزيلا لكل من شرح كود 

شكرا جزيلا لكل من حاول مساعدتي

شكرا لك اخي طارق محمود

شكرا لك اخي جمال عبد السميع

شكرا لك اخي عبد الله المجرب

جزاكم الله خيرا لا اعرف كيف ارد معروفكم لكن الله ييسر لكم ويرزقكم من واسع فضله

ويسهل جميع اموركم