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

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


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

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

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

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

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

و فى حالة كتابة رقم 0 او ترك الخلية فارغة فيقوم بأستدعاء جميع الفواتير بجميع التواريخ

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

كود استدعاء فواتير.rar

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

  • 2 weeks later...

أخي الكريم إليك الكود التالي بعد التعديل في الكود الموجود ليناسب طلبك

Sub FindAllBills()
    Dim WS As Worksheet, SH As Worksheet
    Dim Arr, I As Long
    Set WS = Sheets("فاتورة"): Set SH = Sheets("استدعاء فاتورة")

    With Application
        .ScreenUpdating = False: .Calculation = xlManual: .EnableEvents = False
    End With

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

    With Application
        .EnableEvents = True: .Calculation = xlAutomatic: .ScreenUpdating = True
    End With
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

 

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

أخي الكريم محمود

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

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

الاستاذ  /  ياسر                              المحترم

تحية طيبة

افيدكم باننى استفدت كثيرا من هذا الصرح العظيم ومن اعمال الاعضاء الكرام

افيدكم باننى استخدم اةفيس 2007

وليكن مثال للملف الذى تعمل علية خاليا

زكثيرا ناتظهر لى هذه الرسالة

New Microsoft Office Word Document.rar

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

الأستاذ القدير / ياسر خليل

الكود بعد التعديل يعمل بشكل رائع جدا

و لكن يبقى جزء يسيط و هو استدعاء كافة فواتير العميل عند كتابة صفر فى خلية التاريخ (C3) او تركها فارغة

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

 

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

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