تعديل فى كود استدعاء فاتورة

[طارق_طلعت]

بعد التحية

 

مرفق ملف بة كود استدعاء فاتورة قام بعملة الأستاذ الكبير / ياسر خليل و هو يقوم بأستدعاء فاتورة واحدة عند كتابة رقم الفاتورة بالخلية  A2 

و المطلب عمل تعديل فى الكود بحيث يقوم بأستدعاء عدة فواتير مرة واحدة عن كتابة رقم كود العميل بالخلية A3 ( او فى نفس الخلية A2  ان امكن)

حيث يذهب الى صفحة فاتورة و استدعاء جميع الفواتير التى يوجد بها كود العميل المطلوب و التى تكون فى العمود C

مع بقاء الكود الأصلى يعمل كما هو

بحيث عن كتابة رقم فاتورة فى الخلية  A2  و الضغط على      ENTER  يتم استدعاء الفاتورة المطلوبة

و عند كتابة رقم كود العميل بالخلية  A3 و الضغط على    ENTER يتم استدعاء جميع الفواتير الخاصة بالعميل

 و ايضا يمكن استدعاء فواتير العميل التى تمت فى شهر معين ( يناير - فبراير - مارس -----) بناء على كتابة رقم الشهر فى خلية اخرى

ارجو ان اكون قد استطعت توصيل الفكرة

 

و شكرا جزيلا للمساعدة

 

استدعاء فاتورة.rar

تم تعديل أغسطس 17, 2015 بواسطه طارق_طلعت

[طارق_طلعت]

الاخ العزيز ياسر خليل

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

 

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

[ياسر خليل أبو البراء]

أخي الكريم

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

إليك الكود التالي (استغرق مني وقت طويل فلا تبخل علينا بدعوة لن تستغرق مني ثواني) ...جرب الكود التالي ..قم بكتابة كود العميل ثم اضغط زر الأمر الموجود في ورقة العمل Find All Bills

الكود المستخدم :

Sub FindAllBills()
    Dim WS As Worksheet, SH As Worksheet
    Dim Arr, I As Long
    Set WS = Sheets("فاتورة"): Set SH = Sheets("استدعاء فاتورة")
    
    If IsEmpty(SH.Range("A3")) Then MsgBox "أدخل كود العميل المطلوب استدعاء فواتيره", 64: Exit Sub
    SH.Range("A4:N1000").Clear
    
    Arr = Split(FindRange(SH.Range("A3"), WS.Columns("C:C")), ",")
    For I = LBound(Arr) To UBound(Arr)
        On Error Resume Next
        WS.Range(Arr(I)).CurrentRegion.Copy SH.Range("A" & SH.Cells(Rows.Count, 1).End(3).Row + 2)
    Next I
End Sub

Function FindRange(FirstRange As Range, ListRange As Range) As String
    Dim aCell As Range, bCell As Range, oRange As Range
    Set oRange = ListRange.Find(what:=FirstRange.Value, LookIn:=xlValues, Lookat:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

    If Not oRange Is Nothing Then
        Set bCell = oRange: Set aCell = oRange

        Do
            Set oRange = ListRange.Find(what:=FirstRange.Value, After:=oRange, LookIn:=xlValues, Lookat:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            If Not oRange Is Nothing Then
                If oRange.Address = bCell.Address Then Exit Do
                Set aCell = Union(aCell, oRange)
            Else
                Exit Do
            End If
        Loop
        FindRange = aCell.Address
    Else
        FindRange = "Not Found"
    End If
End Function

لا تنسى أن تحدد أفضل إجابة ليظهر الموضوع مجاب ومنتهي ..

تقبل تحياتي

Find All Bills YasserKhalil.rar

تم تعديل أغسطس 18, 2015 بواسطه ياسر خليل أبو البراء

[طارق_طلعت]

استاذ ياسر العظيم

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

 

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

مرة اخرى شكرا جزيلا

 

[ياسر خليل أبو البراء]

الحمد لله الذي بنعمته تتم الصالحات

الحمد لله الذي هدانا لهذا وما كنا لنهتدي لولا أن هدانا الله

جزيت خيراً على دعائك لي بظهر الغيب وجزيت بمثله إن شاء الله

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

تقبل تحياتي