أكاديمية الصقر للتدريب

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
أحمد يوسف ali mohamed ali-- لا تميز خلال هذه الفترة YasserKhalil عمل زر ماكرو لمربع البحث اكسيل اسئله واجابات


اعلان هنا
صقور الاكسيل
أعلن هنا
أعلن هنا
صفحتنا على الفيس بوك
أعلن هنا


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





تعديل الكود

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



09-01-2020 10:38 مساء
mostah
menu_open
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 10-07-2019
رقم العضوية : 13735
المشاركات : 92
الجنس : ذكر
تاريخ الميلاد : 1-1-1966
يتابعهم : 13
يتابعونه : 2
قوة السمعة : 111
الاعجاب : 1
 offline 
 اخواني  حاولت حل امشكلة الكود خاص ببطاقة الصنف و لكن مع الاسف الشديد لم اصل الى الحل النهائي  مع العلم بان البطاقة تعمل بصورة ممتازة جدا" من جميع النواحي ما عدا مشكلة بسيطة جدا" الى وهو
عند ادخال البحث عن الصنف ياتي بالوارد و المصروف جميع الاصناف و المطلوب هو صنف واحد فقط (يعني عندما ابحث عن مصروف شاي ياتيني بالوارد و المصروف الشاي فقط     
 
عند بحث في خلية في خلية c8 ياتي فقط بالمطلوب فقط ليس جميع الوارد و الصرف مثلا" في خلية c8 كتبنا 1 و هو رقم الصنف خاص بالشاي ياتي فقط بالوارد و الصرف شاي فقط
و اذا كتبنا في خلية c8 كتبنا 2 و هو رقم الصنف خاص بالسكر ياتي فقط بالوارد و الصرف سكر فقط
و اذا كتبنا في خلية c8 كتبنا 3 و هو رقم الصنف خاص بالحليب ابو قوس ياتي فقط بالوارد و الصرف حليب ابوقوس فقط

Private Sub CommandButton1_Click()
    Dim v, x, y, wsItems As Worksheet, wsWared As Worksheet, wsSarf As Worksheet, sh As Worksheet, lr As Long
    lr = [c10000].End(xlUp).Row
Sheets("E?C?E C????").Range("b12:i10000").ClearContents
Application.ScreenUpdating = False
            Set wsItems = ThisWorkbook.Worksheets("بيانات الاصناف")
        Set wsWared = ThisWorkbook.Worksheets("تقرير الوارد")
        Set wsSarf = ThisWorkbook.Worksheets("تقرير الصرف")
        Set sh = ThisWorkbook.Worksheets("بطاقة الصنف")
        lr = Application.Max(12, sh.Cells(Rows.Count, 3).End(xlUp).Row + 1)
                If sh.Range("C8").Value = "" Then Exit Sub
                v = Application.Match(sh.Range("C8").Value, wsItems.Columns(2), 0)
        If Not IsError(v) Then
            sh.Cells(8, 3).Resize(1, 4).Value = wsItems.Cells(v, 2).Resize(1, 4).Value
            sh.Range("I11").Value = wsItems.Cells(v, 6).Value
            sh.Range("B11").Value = DateSerial(Year(Date), 1, 1)
        End If
                x = Application.Match(sh.Range("C8").Value, wsWared.Columns(1), 0)
        If Not IsError(x) Then
            sh.Cells(lr, 2).Resize(1, 2).Value = wsWared.Cells(x, 2).Resize(1, 2).Value
            sh.Cells(lr, 4).Resize(1, 2).Value = wsWared.Cells(x, 8).Resize(1, 2).Value
                    End If
                y = Application.Match(sh.Range("C8").Value, wsSarf.Columns(1), 0)
        If Not IsError(y) Then
            sh.Cells(lr, 6).Value = wsSarf.Cells(y, 3).Value
            sh.Cells(lr, 7).Resize(1, 2).Value = wsSarf.Cells(y, 8).Resize(1, 2).Value
         
        End If
       Application.ScreenUpdating = True
          
End Sub



لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
 
 
  Book1.zip   تحميل zip مرات التحميل :(3)
الحجم :(190.022) KB





10-01-2020 06:50 صباحا
مشاهدة مشاركة منفردة [1]
YasserKhalil
menu_open عضوية موثقة
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 8706
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 21
يتابعهم : 0
يتابعونه : 443
قوة السمعة : 25633
الاعجاب : 247
 offline 
look/images/icons/i1.gif تعديل الكود
السلام عليكم
أولاً يرجى تعديل العنوان ليكون معبر عن الموضوع بشكل أفضل
ثانياً الملف المرفق لا يوجد به أية أكواد ولا يوجد تفاصيل كافية عن المشكلة لذا حاول وضع صور بشكل المتوقع
ثالثاً عند وضع كود في الموضوع يرجى مراعاة أن يكون اتجاه الكتابة باللغة العربية لكي يتم نسخ الكلمات التي باللغة العربية بشكل صحيح
رابعاً حاول استخدام لغة الإكسيل في الشرح كأن تقول ورقة العمل كذا والعمود كذا والصف كذا والمعطيات الموجودة بالشكل كذا وأريد أن تظهر النتائج بالشكل كذا بناءً على الشروط كذا وكذا ..




10-01-2020 09:41 صباحا
مشاهدة مشاركة منفردة [2]
YasserKhalil
menu_open عضوية موثقة
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 8706
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 21
يتابعهم : 0
يتابعونه : 443
قوة السمعة : 25633
الاعجاب : 247
 offline 
look/images/icons/i1.gif تعديل الكود
أخي الكريم
يرجى الانتباه لكل توجيه ..
لم تقم بتغيير عنوان الموضوع ، ولم ترفق ملف به الكود نفسه ، ولم تدرج الكود بين أقواس الكود بشكل صحيح (قمت بتعديل مشاركتك لتصحيح شكل الكود) ............ !!!!
كذلك عند إرفاق ملف يراعى أن تكون البيانات في حدود 20 صف فقط لتجربة الأكواد بشكل صحيح ومعرفة ما إذا كان الكود يؤدي الغرض أم لا ..
في الحقيقة معاناة مع ملفك لعمل المطلوب عليه ، لذا الرجاء الالتزام بقواعد المشاركة وإلا لن تجد استجابة لا مني ولا من غيري

جرب الكود التالي عله يفي بالغرض إن شاء الله
Sub Test()
    Dim a, b, v, wsItems As Worksheet, wsWared As Worksheet, wsSarf As Worksheet, sh As Worksheet, lr As Long, i As Long, k As Long

    Application.ScreenUpdating = False
        Set wsItems = ThisWorkbook.Worksheets("بيانات الاصناف")
        Set wsWared = ThisWorkbook.Worksheets("تقريرالوارد")
        Set wsSarf = ThisWorkbook.Worksheets("تقريرالصرف")
        Set sh = ThisWorkbook.Worksheets("بطاقة الصنف")
        
        sh.Range("A12:I" & Rows.Count).ClearContents
        lr = Application.Max(12, sh.Cells(Rows.Count, 3).End(xlUp).Row + 1)
        If sh.Range("C8").Value = "" Then Exit Sub
        
        v = Application.Match(sh.Range("C8").Value, wsItems.Columns(2), 0)
        If Not IsError(v) Then
            sh.Cells(8, 3).Resize(1, 4).Value = wsItems.Cells(v, 2).Resize(1, 4).Value
            sh.Range("I11").Value = wsItems.Cells(v, 6).Value
            sh.Range("B11").Value = DateSerial(Year(Date), 1, 1)
        End If
        
        k = 0
        a = wsWared.Range("A9:I" & wsWared.Cells(Rows.Count, 3).End(xlUp).Row).Value
        ReDim b(1 To UBound(a, 1), 1 To 5)
        For i = LBound(a) To UBound(a)
            If a(i, 4) = sh.Range("C8").Value Then
                k = k + 1
                b(k, 1) = a(i, 1)
                b(k, 2) = a(i, 2)
                b(k, 3) = a(i, 3)
                b(k, 4) = a(i, 8)
                b(k, 5) = a(i, 9)
            End If
        Next i
        If k > 0 Then sh.Range("A" & lr).Resize(k, UBound(b, 2)).Value = b
        
        k = 0
        a = wsSarf.Range("A9:I" & wsSarf.Cells(Rows.Count, 3).End(xlUp).Row).Value
        ReDim b(1 To UBound(a, 1), 1 To 3)
        For i = LBound(a) To UBound(a)
            If a(i, 4) = sh.Range("C8").Value Then
                k = k + 1
                b(k, 1) = a(i, 3)
                b(k, 2) = a(i, 8)
                b(k, 3) = a(i, 9)
            End If
        Next i
        If k > 0 Then sh.Range("F" & lr).Resize(k, UBound(b, 2)).Value = b
   Application.ScreenUpdating = True
End Sub




10-01-2020 10:13 صباحا
مشاهدة مشاركة منفردة [3]
mostah
menu_open
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 10-07-2019
رقم العضوية : 13735
المشاركات : 92
الجنس : ذكر
تاريخ الميلاد : 1-1-1966
يتابعهم : 13
يتابعونه : 2
قوة السمعة : 111
الاعجاب : 1
 offline 
look/images/icons/i1.gif تعديل الكود
استاذ ياسر
لا تسعفني كلماتي فأمدحك ولا يستيقظ عقلي من غيبته لأشكرك فمقامك محفظٌ بعلمك وقدرك محفوفٌ في صدورنا بتواضعك بوركت أيها المعلم القدير،
هذا هو المطلوب 100%

3dlat.com_02_18_9b08_a52d318330d32


 




10-01-2020 01:46 مساء
مشاهدة مشاركة منفردة [4]
YasserKhalil
menu_open عضوية موثقة
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 8706
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 21
يتابعهم : 0
يتابعونه : 443
قوة السمعة : 25633
الاعجاب : 247
 offline 
look/images/icons/i1.gif تعديل الكود
بارك الله فيك أخي الكريم مسطاح ومشكور على كلماتك الطيبة ودعائك الطيب
الحمد لله الذي بنعمته تتم الصالحات






المواضيع المتشابهه
عنوان الموضوع الكاتب الردود الزوار آخر رد
اكواد لادخال بيانات وتعديلها محمد9009
7 70 محمد9009
تعديل واضافة كود ابوبكر المتولي
11 201 ابوبكر المتولي
تعديل على كود حماية الصفحات ليتم حماية صفحات ماعدا صفحات محددة كما هو بالمرفق ابو طيبه
15 376 ابو طيبه
تعديل على كود الترحيل واستدعاء بيانات من شيت لاخر وعمل قائمة منسدله ابو طيبه
14 588 ابو طيبه
تعديل وتطابق اظهار البيانات بالليست بوكس كورقة الإكسيل المبتدأ
7 197 المبتدأ

الكلمات الدلالية
تعديل ، الكود ،


 







اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.

الساعة الآن 10:47 مساء

أعلن هنا
أعلن هنا
أعلن هنا