تعديل على كود

[يوسف السيد]

السلام عليكم :

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

وقد قمت ببعض التعديلات الطفيفة عليه .. والكود يعمل ويجلب النتائج المطلوبة

ولكن المشكلة هى بطئ الكود .

اتمنى من الاخوة التعديل على الكود حتى يعمل بشكل اسرع

حسابات 2013-12-4.rar

[أبو حنــــين]

السلام عليكم

اخي يوسف جرب المرفق

 

*************************************

تم تعديل المرفق

 

 

حسابات 2013-12-4 _3.rar

تم تعديل ديسمبر 16, 2013 بواسطه أبو حنين

[يوسف السيد]

وعليكم السلام :

استاذى الفاضل ابو حنين بارك الله فيك 

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

ولكن اتمنى ان يتم تجميع البنود المتشابهة فى بند واحد ووضع المبلغ الاجمالى امام كل بند

بحيث يكون البند مذكور مرة واحدة فى التقرير .

 

[عبدالله باقشير]

السلام عليكم

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

Option Explicit

Private Const ContColmn As Integer = 5
'======================================================
'======================================================

Sub kh_Report()
Dim obj As Object
Dim xx(), x()
Dim v As String
Dim LastRow As Long, iCont As Long
Dim i As Long, ii As Long, iii As Long
Dim C As Integer
''''''''''''''''''''''
On Error GoTo kh_ex

Set obj = CreateObject("Scripting.Dictionary")
'''''''''''''''''''''
'============================================
With Range("B9:F9")
    .ClearContents
    Range(.Offset(1, 0), .Offset(1, 0).End(xlDown)).Clear
End With
'============================================
kh_Application False

'''''''''''''''''''''
With Sheets("database")
    LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
    
    For i = 5 To LastRow
        If kh_Test(CStr(.Cells(i, "F")), .Cells(i, "C").Value2) Then
            v = .Cells(i, "E").Value
            If obj.Exists(v) Then
                iii = obj(v)
                ''''''''''''''''''
                xx(3, iii) = xx(3, iii) + Val(.Cells(i, "G"))
                xx(4, iii) = xx(4, iii) + Val(.Cells(i, "H"))
            Else
                ii = ii + 1
                ReDim Preserve xx(1 To 4, 1 To ii)
                obj.Add v, ii
                ''''''''''''''''''
                xx(1, ii) = ii
                xx(2, ii) = v
                xx(3, ii) = Val(.Cells(i, "G"))
                xx(4, ii) = Val(.Cells(i, "H"))
            End If
       
        End If
     Next
End With
'''''''''''''''''''''''''''''''
iCont = obj.Count
If iCont Then

    ReDim x(1 To iCont, 1 To ContColmn)
    For i = 1 To iCont
        For C = 1 To 4
            x(i, C) = xx(C, i)
        Next
        x(i, 5) = x(i, 3) - x(i, 4)
    Next
    
    With Range("B9").Resize(iCont, ContColmn)
        If iCont > 1 Then .Rows(1).AutoFill .Cells, xlFillFormats
        .Value = x
        
        Range("RngTotal").Copy .Cells(iCont + 1, 1)
        .Cells(iCont + 1, 3) = WorksheetFunction.Sum(.Columns(3))
        .Cells(iCont + 1, 4) = WorksheetFunction.Sum(.Columns(4))
    End With
    
    '''''''''''''''''''''''''
End If
'============================================

kh_ex:
kh_Application True
''''''''''''''''''
''''''''''''''''''
''''''''''''''''''

Set obj = Nothing
Erase xx, x
''''''''''''''''''
If Err Then
    MsgBox "Err.Number : " & Err.Number
    Err.Clear
End If
End Sub

Function kh_Test(Nm As String, Dt) As Boolean
Dim ib As Boolean
If Nm <> [C5] Then GoTo 1
Select Case Dt
    Case [E5] To [E6]
    ib = True
End Select
1:
kh_Test = ib
End Function

Sub kh_Application(mbol As Boolean)
With Application
    .Calculation = IIf(mbol, -4105, -4135)
    .ScreenUpdating = mbol
    .EnableEvents = mbol
End With
End Sub

 

شاهد المرفق 2010

تقرير خبوري.rar

[يوسف السيد]

وعليكم السلام :

الاستاذ الكبير : عبدالله باقشير

الكود يؤدى المطلوب بدقة وكفاءة 

جزاك الله خيرا وبارك لك ونفع بك

[أبو حنــــين]

السلام عليكم

بعد ان  انجزت الملف وجدت ان اخي عبد الله قد قام بالمهمة قبلي

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

و لاثراء الموضوع  فقط  ارفقت الملف

 

حسابات 2013-12-4 _34.rar

تم تعديل ديسمبر 16, 2013 بواسطه أبو حنين

[يوسف السيد]

وعليكم السلام :

استاذى الفاضل : ابو حنين 

تنفذ منى الكلمات ولا اجد ما اقول سوى " انى احبك فى الله "