اذهب الي المحتوي
أوفيسنا

قائمه منسدله


إذهب إلى أفضل إجابة Solved by عادل حنفي,

الردود الموصى بها

اخواني الاعزاء تحية طيبه في احد البرامج التي استخدمها تفاصيل لما يقرب من (500) قائمه كما في المرفق ، اود مساعدتكم بكود وقائمه منسدله توصلني الى تفاصيل القائمه بمجرد ضغط رقمها مع الشكر

_____.rar

رابط هذا التعليق
شارك

اخى العزيز

الملف المرفق اتمنى ان يكون هو المطلوب

وقد استخدمت فيه الدالة VLOOK2ALL للاستاذ العزيز عمر الحسينى

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

1_____.rar

رابط هذا التعليق
شارك

ألاخوة الاعزاء تحية طيبه في الوقت الذي اشكركم فيه على سرعة الرد وروعته اود ايضاح ما يلي :

1-الحل الاول اقرب للمطلوب متسائلا عن امكانية وضع ورقة (تفاصيل) ضمن (ورقة1)وما الذي يتحتم علي تغييره عند نسخ الاكواد الى ورقة العمل التي اعمل عليها .

2-الحل الثاني يؤشر رقم القائمه فقط اي لا يمكن الذهاب الى تفاصيلها كما هو الحال في الحل الاول والذي اطمح اليه هو الوصول الى تفاصيل القائمه بمجرد الضغط على رقم القائمه من المنسدله بدلا من البحث عنها .

مع الشكر والامتنان

رابط هذا التعليق
شارك

الاخ العزيز

aah_aah200

حل اكثر من رائع

ولى طلب ارجو ان تلبيه

ما هو المكرو الذى تم عمل القائمة الموجود بصفحة ترتيب القوائم

والتى على اساسها تم عمل القائمة المنسدلة

اريد فقط الماكرو الذى يضيف بصفحة ترتيب القوائم اى اضافة جديدة الى خانة القائمة

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

رابط هذا التعليق
شارك

السلام عليكم

اخي gadelrab

اشكرك اخي علي كلماتك

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

ولكي نجعل الكود الموجود بصفحة ترتيب القوائم يوجد في الكود الموجود ايضا عند الضغط علي الزر ناكتف صفحة1 ثم ناكتف صفحة ترتيب القوائم

ليعمل الكود الذي بها ثم ناكتف مرة اخري صفحة 1 و هكذا يكون القائمة المنسدله جاهزه للعمل

و الكود الموجود بصفحة تريب القوائم هذا هو و هو منقسم لقسمين احدهما لازالة المكرر و الاخر للترتيب

Private Sub Worksheet_Activate()
  If Range("B1") = "0" Then
  Exit Sub
  Else
  On Error Resume Next
    Range("A2:A500").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    ActiveSheet.UsedRange
    End If
 Dim x As Long
    Dim LastRow As Long
    LastRow = Range("A400").End(xlUp).Row
    For x = LastRow To 1 Step -1
        If Application.WorksheetFunction.CountIf(Range("A2:A" & x), Range("A" & x).Text) > 1 Then
            Range("A" & x).EntireRow.Delete
        End If
    Next x
    Range("A3:A100").Sort Key1:=Range("A3"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

End Sub

خالص تحياتي

تم تعديل بواسطه aah_aah2008
رابط هذا التعليق
شارك

أخواني الاعزاء مع تقديري واعجابي بجميع الحلول المقدمه ارفق طيا نسخة طبق الاصل لورقة العمل التي اعمل عليها راجيا تدخلكم لوضع الاكواد التي تضمنتها الحلول ضمنها لتسهيل نقلها مع الامتنان

_____3.zip

رابط هذا التعليق
شارك

استاذنا العزيز ، تحية طيبه، حيث اني لم اوفق في الوصول الى الغاية المطلوبه بعد اجراءي التغيير اللازم على المرفق الاخير ، ارجو المساعده في :

1-تغيير اسم ( ورقه1) ليكون (المبيعات).

2-كيفية عمل ودور ورقة ترتيب القوائم في هذا الحل .

3-في عمود القائمه انا احاول تنزيل ارقام القوائم امام كل رمز للماده للاستفاده حين الفرز ، اي تنزيل الرقم (1) كما في المثال امام كل ماده وهكذا بقية الارقام .

شاكرا جهودكم الخيره مع الامتنان

رابط هذا التعليق
شارك

السلام عليكم

اخي العزيز

صفحة ترتيب القوائم لا تحتاجها انت في شيئ بل يحتاجها البرنامج لانها تخدم

القائمة المنسدله و هي ايضا التي يتم بها فرز المكرر من القوائم و ترتيبه

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

و تم التغيير لصفحة المبيعات بدلا من ورقة1

و تم جعلك تتمكن من انزال اسم القئمة امام رموز القائمة و التعديل بناء علي هذا

تم عمل هذا الكود ليمل حتي 10000 صف

ارجو التجربة و اخباري بالنتيجة

تحياتي

_____.rar

رابط هذا التعليق
شارك

استاذنا العزيز مع احترامي وتقديري لجهدكم الرائع وصبركم علينا يظهر انني لم اوفق ثانية في التوصل الى المراد والسبب هو ورقة ( ترتيب القوائم ) صحيح انها مخفيه ولكنها ضروريه عند رغبتي نقل محتويات المثال الى برنامجي الذي اعمل عليه . الرجاء ايضاح كيفية ادخال ارقام القوائم فيها ( كيفية الاعداد ) حيث ان برنامجي يحوي ما يقارب ال( 500 ) قائمه تحتاج التفاتة رائعه منكم في كيفية ادخالها في هذه القائمه لتعمل الاكواد بصورة طبيعيه مع الامتنان

رابط هذا التعليق
شارك

السلام عليكم

اخي العزيز

اولا و كما قلت سابقا ان الكود يعمل و حتي الصف ال10000

مما يتيح العمل علي مجموعة قوائم كبيرة

ثانيا كل ماعليك انشاء شيت اسمه ترتيب القوائم مع دعمه بالاكواد الخاصة به بملفي

و لن تكتب به اي شئ فهو كصفحة مساعدة فقط يتم نسخ القوائم به و الغاء المكرر ثم الترتيب(هذا كله بالكود طبعا)

لتظهر القائمة المنسدلة كما هي الان

ارجو ان تكون المعلومة وصلت و لو فيه اي شئ اخبرني

تحياتي

تم تعديل بواسطه aah_aah2008
رابط هذا التعليق
شارك

  • 2 weeks later...

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

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

رابط هذا التعليق
شارك

  • أفضل إجابة

السلام عليكم

اخي العزيز tofimoon4

ما هو الذي يقف امامك

اخي كل ما عليك هو الاتي

انشاء صفحة و سمها باسم ترتيب القوائم

و في محرر كودها الصق هذا الكود

Private Sub Worksheet_Activate()
  If Range("B1") = "0" Then
  Exit Sub
  Else
  On Error Resume Next
    Range("A2:A10000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    ActiveSheet.UsedRange
    End If
 Dim x As Long
    Dim LastRow As Long
    LastRow = Range("A400").End(xlUp).Row
    For x = LastRow To 1 Step -1
        If Application.WorksheetFunction.CountIf(Range("A2:A" & x), Range("A" & x).Text) > 1 Then
            Range("A" & x).EntireRow.Delete
        End If
    Next x
    Range("A3:A10000").Sort Key1:=Range("A3"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

End Sub

و الخليه B1 بهذه الصفحة بها معادله انسخها ايضا و الصقها في الخليه B1

جرب و قولي ما يحدث و نحن معك الي ان يتم ما تريد

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

جديد فقط قم بكتابة 1 في الخليه A3

وبعد ذلك سيكون العمل بشكل عادي فلسبب ما اجهله الان قمت بكتابة شرط

ان الخليه B1 اذا كانت تساوي صفرا لا يعمل الكود و اكيد انا عملت ده لسبب

ما لا اتذكره الان و حتي لا اكون متسرعا و اقولك الغي هذا الشرط

قم بعمل ما قلته لك و ان شاء الله يعمل الملف معاك

تحياتي

تم تعديل بواسطه aah_aah2008
رابط هذا التعليق
شارك

Private Sub Worksheet_Activate()

If Range("B1") = "0" Then

Exit Sub

Else

On Error Resume Next

Range("A2:A10000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

ActiveSheet.UsedRange

End If

Dim x As Long

Dim LastRow As Long

LastRow = Range("A400").End(xlUp).Row

For x = LastRow To 1 Step -1

If Application.WorksheetFunction.CountIf(Range("A2:A" & x), Range("A" & x).Text) > 1 Then

Range("A" & x).EntireRow.Delete

End If

Next x

Range("A3:A10000").Sort Key1:=Range("A3"), Order1:=xlAscending, Header:= _

xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _

DataOption1:=xlSortNormal

End Sub

يا حبذا استاذي العزيز شرح لهذا الكود لكي افهمه ... فلا استطيع ان اطبق شيء لا افهمه

يا رب تتحمل اسئلتي يارب .............

رابط هذا التعليق
شارك

السلام عليكم

اخي dayslife

Private Sub Worksheet_Activate() في حدث التفعيل للشيت

If Range("B1") = "0" Thenاذا كانت الخلية B1=0

Exit Sub يتوقف عمل الكود

Else اذا لم تكن =0

On Error Resume Next هذا كود لالغاء الخلايا الفارغة

Range("A2:A10000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

ActiveSheet.UsedRange

End If

Dim x As Long و هذا كود اخر يؤدي نفس و ظيفة السابق استعنت به لان الاول و جدته لا يحذف الخلايا الفارغة بالكامل لسبب لم ابحث عنه في هذا الملف

Dim LastRow As Long

LastRow = Range("A400").End(xlUp).Row

For x = LastRow To 1 Step -1

If Application.WorksheetFunction.CountIf(Range("A2:A" & x), Range("A" & x).Text) > 1 Then

Range("A" & x).EntireRow.Delete

End If

Next x

Range("A3:A10000").Sort Key1:=Range("A3"), Order1:=xlAscending, Header:= _و هذا كود لعمل الترتيب من الاصغر فالاكبر

xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _

DataOption1:=xlSortNormal

End Sub

تحياتي

رابط هذا التعليق
شارك

السلام عليكم

Dim x As Long و هذا كود اخر يؤدي نفس و ظيفة السابق استعنت به لان الاول و جدته لا يحذف الخلايا الفارغة بالكامل لسبب لم ابحث عنه في هذا الملف

Dim LastRow As Long

LastRow = Range("A400").End(xlUp).Row

For x = LastRow To 1 Step -1

If Application.WorksheetFunction.CountIf(Range("A2:A" & x), Range("A" & x).Text) > 1 Then

Range("A" & x).EntireRow.Delete

End If

Next x

اعتقد هذا كود لحدف المكرر

تحياتي

رابط هذا التعليق
شارك

السلام عليكم

اخوانا واساتذتنا الكرام

لماذا نستخدم الماكرو فى كل حلولنا لمشاكل الاكسيل

مع انه يمكن الحل بدون ماكرو لبعض المشاكل

ارجوا اخبارى لو سمحتم

وتقبلوا تحياتى

اسماعيل

رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information