اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

استخلاص بيانات بدلالة اعمده معينة


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

السلام عليكم

السادة الأفاضل/ خبراء اكسيل

تحية طيبة

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

مرفق الملف

الشيت الأول به بيانات مجمعه

الشيت الثانى  ارغب فيه  عند الأختيار من القائمة المنسلة يظهر بيانات الختيار فقط

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

ولكم جزيل الشكر والعرفان

استخلاص بيانات من أعمده وصقوق.rar

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

أخي الكريم

يرجى مراجعة التوجيهات كما يرجى تغيير اسم الظهور للغة العربية عملاً بقواعد المنتدى

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

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

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$H$2" Then
        Dim WS As Worksheet, SH As Worksheet
        Dim FindMon, I As Long
        Set WS = Sheet1: Set SH = Sheet2

        With Application
            .ScreenUpdating = False: .Calculation = xlManual: .EnableEvents = False
        End With
            With SH
                .Range("A4:C12").ClearContents
    
                FindMon = Application.Match(.Range("H2").Value, WS.Rows(3), 0)
                If IsNumeric(FindMon) Then
                    WS.AutoFilterMode = False
                    WS.Rows(3).AutoFilter Field:=FindMon, Criteria1:="<>" & ""
                    WS.Range("B4:B26").SpecialCells(xlCellTypeVisible).Copy
                    .Range("B4").PasteSpecial xlPasteValues
                    WS.Range(WS.Cells(4, FindMon), WS.Cells(26, FindMon)).SpecialCells(xlCellTypeVisible).Copy
                    .Range("C4").PasteSpecial xlPasteValues
                    WS.AutoFilterMode = False
                Else
                    MsgBox "No Mathing Data", 64: Exit Sub
                End If
    
                If Not IsEmpty(.Range("B4")) Then
                    For I = 4 To .Cells(13, "B").End(xlUp).Row
                        .Cells(I, "A") = .Cells(I, "A").Row - 3
                    Next I
                End If
                .Range("H2").Select
            End With
        With Application
            .EnableEvents = True: .Calculation = xlAutomatic: .ScreenUpdating = True
        End With
    End If
End Sub

وإليك الملف المرفق فيه تطبيق الكود

تقبل تحياتي

استخلاص بيانات من أعمده وصفوف.rar

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

الأستاذ الفاضل / ياسر

بداية أشكر حضرتك شكرا جزيلا على علمك ولطفك وسعيك لتقديم كل مالديكم من علم  ومساعدة الآخرين

الكود يعطى رسالة خطأ فى السطر  .Range("B4").PasteSpecial xlPasteValuesولا يعمل

ثانيا : هل يمكن استخدم الدوال بدلا من الأكواد فمثلا هل يمكن استخدام الدالة index ، match ، small للوصول الى نفس النتيجة

واشكرك

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

هل قمت بتطبيق الكود على نفس الملف أم ملف آخر ؟؟

الكود يعمل معي بشكل طبيعي وعادي جداً ..لأني عادةً لا أرفق كود إلا بعد تجربته أكثر من مرة

بالنسبة للمعادلات .. كان من المفترض أن تحدد في المشاركة الأولى أن يكون الحل بالمعادلات ..تحديد الطلب مهم ..

عموماً سأحاول أن أقدم لك حل آخر بالمعادلات ..

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

اساتذى  الفاضل

نفس الملف لايعمل عندى يمكن علشان انا باستخدم office 2003 

باشكر حضرتك على الأهتمام والمساعده

ويارب ماأكون اثقلت عليكم

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

السلام عليكم و رحمة الله وبركاته

اخي الجبيب و الأستاذ القدير ياسر خليل

الف شكر على الكود الجميل الذي به الكثير من المجهود الجبار و الخصائص الرائعة 

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

الأستاذ الفاضل / ياسر

بداية أشكر حضرتك شكرا جزيلا على علمك ولطفك وسعيك لتقديم كل مالديكم من علم  ومساعدة الآخرين

الكود يعطى رسالة خطأ فى السطر  .Range("B4").PasteSpecial xlPasteValuesولا يعمل

ثانيا : هل يمكن استخدم الدوال بدلا من الأكواد فمثلا هل يمكن استخدام الدالة index ، match ، small للوصول الى نفس النتيجة

واشكرك

اساتذى  الفاضل

نفس الملف لايعمل عندى يمكن علشان انا باستخدم office 2003 

باشكر حضرتك على الأهتمام والمساعده

ويارب ماأكون اثقلت عليكم

السادة الفضلاء 

لكي يعمل الكود السابق يجب عليكما الغاء دمج الخلايا في الخلية الصفراء و المكتوب بها الجمله

تحياتي

السلام عليكم و رحمة الله وبركاته

اخي الجبيب و الأستاذ القدير ياسر خليل

الف شكر على الكود الجميل الذي به الكثير من المجهود الجبار و الخصائص الرائعة 

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

الأستاذ الفاضل / ياسر

بداية أشكر حضرتك شكرا جزيلا على علمك ولطفك وسعيك لتقديم كل مالديكم من علم  ومساعدة الآخرين

الكود يعطى رسالة خطأ فى السطر  .Range("B4").PasteSpecial xlPasteValuesولا يعمل

ثانيا : هل يمكن استخدم الدوال بدلا من الأكواد فمثلا هل يمكن استخدام الدالة index ، match ، small للوصول الى نفس النتيجة

واشكرك

اساتذى  الفاضل

نفس الملف لايعمل عندى يمكن علشان انا باستخدم office 2003 

باشكر حضرتك على الأهتمام والمساعده

ويارب ماأكون اثقلت عليكم

السادة الفضلاء 

لكي يعمل الكود السابق يجب عليكما الغاء دمج الخلايا في الخلية الصفراء و المكتوب بها الجمله

تحياتي

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

اخي الكريم

هذا حل آخر بكود ايضا

كود التصفية المتقدمة

استخلاص بيانات من أعمده وصقوق.rar

مع مراعات الدوال الموجودة في الصف 4

Sub mod_1()

Range("DATA").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("ORDER"), _
CopyToRange:=Range("OUTBUT"), Unique:=False

End Sub

 

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

الأستاذ / أحمد الزمان

اشكرك على المجهود العظيم الرائع

الكود جميل ويعمل لكن هيبقى له مشاكل مع زيادة ونقصان البيانات  لكن

كنت أتمنى من حضراتكم بصفتكم خبراء باستخدم الدوال بدلا من الأكواد مثل index ، match ، small للوصول الى نفس النتيجة

 

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

فعلا تم الغاء دمج الخلايا وفعلا اشتغل الملف

لكن الكو د يظهر الأسماء التي امامها قيمة والأسماء  التي ليس امامها قيمه

 

 

الكلام دا على أي أساس ؟؟

الكود مجرب ويعطي نتائج صحيحة ..

أنا راجعت الملف مرة أخرى ويعطي نتائج صحيحة ...فقط تظهر الأسماء التي لها قيمة في الشهر المحدد

يا ريت يكون فيه دقة في الكلام قبل أن نتكلم أو يكون الكلام مصحوب بدليل مصور أو ملف مرفق

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

الأستاذ / ياسر

تحيه طيبه

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

وعموما انا دقيق في كلامى وقولت اللى حصل عندى وقولت كمان يمكن المشكله علشان انا باستخدم office 2003 وشكرت حضرتك هنا ونفس الرساله أرسلتها لك على الخاص ليس لكى تقوم بالحل ولكن لأبلاغك خوفا من عدم الأطلاع عليها هنا

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

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

واخير اً انا بعتذر لحضرتك وبعتذر انى كمان طرحت الموضوع من الأصل

 

 

صوره من النتيجه.rar

تم تعديل بواسطه خالد الكيلانى
  • Like 1
رابط هذا التعليق
شارك

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