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

[طارق_طلعت]

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

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

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

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

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

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

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

[طارق_طلعت]

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

 

برجاء التكرم بالمساعده فى التعديل المطلوب اذا سمح وقت حضرتك

 

و شكرا جزيلا

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

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

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

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

 

[محمودبك]

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

تحية طيبة وبعد

ارق التهانى على ترقية وتطوير المنتدى

استفسار بسيط عن ظهور هذه الرسالة 

 

New Microsoft Office Word Document.rar

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

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

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

[محمودبك]

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

تحية طيبة

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

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

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

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

New Microsoft Office Word Document.rar

[طارق_طلعت]

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

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

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

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

 

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

الأخ طارق الجزئية الأخيرة موجودة بالفعل اجعل الخلية C3 فارغة وجرب الكود

[طارق_طلعت]

الاستاذ الجليل ياسر

بالفعل تم المطلوب بعد عمل clear contents و هذا كافى جدا

شكرا جزيلا للمساعده كعهدك داءما